0 votes
in VBA by Beginner (48 points)

hi, experts,  

I would like a VBA macro to consodilate different columns from multiple sheets into one sheet 

I know this complicated question, but if solved it will help me.

Let's say sheet1 looks like this: 

sheet2 looks like this: 

I want the combined result in sheet3 to look like this:

2 Answers

0 votes
by Super Expert (3.2k points)
selected by
Best answer

A SQL query, power query or Pivot Table would definitely be better options, but if you're looking for a VBA solution, a macro using a VBA Scripting Dictionary might be your best bet. You'll need to first add a reference to the Microsoft Scripting Runtime from your VBA Editors via the Tools > References menu. Once you do that, here's a macro that would consolidate the sheets in your specific screenshots:

Option Explicit
Sub ConsolidateSheets()
' PREREQUISITES: Set up the VBA dictionary object (Tools > References > Microsoft Scripting Runtime)
' ASSUMPTIONS: (1) The import and export values are in the 5th columns of the original sheet
'              (2) The sheets you want to combine each contain 5 columns
'              (3) The combined import data will go to the 5th column of the combined sheet and
'                  the combined export data will go to the 6th column of the combined sheet.
'              (4) If the BRANDs match, the TYPE and ORIGIN will also match.
Dim dict1 As Scripting.Dictionary 'import
Dim dict2 As Scripting.Dictionary 'export
Dim ws1 As Worksheet              'import
Dim ws2 As Worksheet              'export
Dim wsComb As Worksheet           'combined
Dim iLastRow As Long, i As Long, j As Long
Dim varKey As Variant
Dim dSumImport As Double
Dim dSumExport As Double
Dim crow As Range, cell As Range

'define your sheet names here
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set wsComb = Sheets("Sheet3")

Set dict1 = New Scripting.Dictionary
Set dict2 = New Scripting.Dictionary

'Save the matching Brands to a dictionary for ws1
iLastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row
Set dict1 = DictionaryGroupData(ws1.Range("a1:E" & iLastRow), 2, True)

'Save the matching Brands to a dictionary for ws2
iLastRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
Set dict2 = DictionaryGroupData(ws2.Range("a1:E" & iLastRow), 2, True)

'start adding combined sums to wsComb
wsComb.Rows("2:" & Rows.Count).clear
    'sum the import values for each BRAND
    i = 1
    For Each varKey In dict1.Keys
        dSumImport = 0
        For Each crow In dict1.Item(varKey).Rows
            dSumImport = dSumImport + crow.Cells(5)
        Next crow
        'add each unique BRAND to the wsComb sheet
        i = i + 1
        For Each cell In dict1.Item(varKey).Rows(1).Cells
            wsComb.Cells(i, cell.Column) = cell
        Next cell
        wsComb.Cells(i, 5) = dSumImport
        wsComb.Cells(i, 1) = i - 1
    Next varKey
    'sum the export values for each BRAND
    For Each varKey In dict2.Keys
        dSumExport = 0
        For Each crow In dict2.Item(varKey).Rows
            dSumExport = dSumExport + crow.Cells(5)
        Next crow
        'look for matching row in wsComb sheet
        iLastRow = wsComb.Range("A" & Rows.Count).End(xlUp).Row
        For j = 2 To iLastRow
            If dict2.Item(varKey).Cells(1, 2) = wsComb.Cells(j, 2) Then
                wsComb.Cells(j, 6) = dSumExport
                wsComb.Cells(j, 7).Formula = "=" & wsComb.Cells(j, 5).Address & "-" & wsComb.Cells(j, 6).Address
                Exit For
            End If
        Next j
    Next varKey
End Sub
Function DictionaryGroupData(rngInput As Range, keyColIndex As Long, blHeaders As Boolean) As Scripting.Dictionary
    'Must add reference to Tools > References > Microsoft Scripting Runtime
    Dim i As Long
    Dim rngCell As Range, rng As Range, rngTemp As Range
    Dim dict As Scripting.Dictionary
    Dim strVal As String
    Application.ScreenUpdating = False
    Set rng = rngInput.Columns(keyColIndex)
    Set dict = New Scripting.Dictionary
    ' set compare mode to text
    dict.CompareMode = TextCompare
    ' offset by one row if range has headers
    If blHeaders Then
        With rngInput
            Set rngInput = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
        End With
    End If
    ' add keys and values to dictionary
    With rngInput
        For Each rngCell In rngInput.Columns(keyColIndex).Cells
            i = i + 1
            strVal = rngCell.Text
            ' add new key and item range
            If Not dict.Exists(strVal) Then
                dict.Add strVal, .Rows(i)
            ' merge item ranges of existing key
                Set rngTemp = Union(.Rows(i), dict(strVal))
                dict.Remove strVal ' simply updating the item in a loop will cause a run-time error!
                dict.Add strVal, rngTemp
            End If
        Next rngCell
    End With

    Set DictionaryGroupData = dict
    Application.ScreenUpdating = True

End Function

Without a doubt there are shorter ways to do this with VBA, but I recycled some existing code snippets to speed up my development.

by Beginner (48 points)
thanks for your notes  now i designed  a new spreadsheet  and the same range as you do in  your code  it perfectly works   the problem  is spredsheet as you said   but  i have

a small piont  i hope to help me and find  soloution   in sheet1 contains some  data  not exist in sheet2 then  show in sheet3  but  it doesn't  the value in column7  header quantity

you can test in my file  and note what i mean

sheet3  what you suggest to adjust in the code
by Super Expert (3.2k points)

To add a balance in the 7th column even if there's no value in the export column, add the following code below the line wsComb.Cells(i, cell.Column) = cell

wsComb.Cells(i, 7).Formula = "=" & wsComb.Cells(i, 5).Address & "-" & wsComb.Cells(i, 6).Address


by Beginner (48 points)
thanks  it works  i know  do more my request   i would fine demand    the header export stay empty   is there any way to make 0
by Super Expert (3.2k points)

Add this line in the same spot you added the line above:

wsComb.Cells(i, 6) = 0

I encourage you to study the final code a bit - it should help you learn quite a few things :-)

by Beginner (48 points)
thanks  so much  i appreciate your efforts  indeed i lost  hope to reply me   despite  my subject passed  long time to reply you  what happend in my file    but  you  answered me   your code is very huge  but very usful  it takes  some time to understant  i'll try   understand   despite i'm not programmer
0 votes
by Beginner (5 points)
Did you try this with Power Query?
by Beginner (48 points)
actually  I would  vba  macro   if it's  possible

Welcome to wellsr Q&A
wellsr Q&A is the VBA and Python programming community that rewards you for learning how to code.

Getting Started
VBA Cheat Sheets (On Sale Now)

Earn free prizes for asking VBA and Python questions and for answering questions asked by others in our community.

Looking for something else? Hire our professional VBA Help, instead.

What makes us different?
Our points system rewards you with a chance for free gifts based on the quality of your questions and answers. All you have to do is post and you could get rewarded, like these members:

ParserMonster $25 Amazon Gift Card
Hightree $10 Amazon Gift Card
Thales1 $10 Amazon Gift Card
runfunke $10 Amazon Gift Card
coolag $10 Amazon Gift Card
Siew Hun $10 Amazon Gift Card

So, why don't you join us? It really is an encouraging way to motivate members in our VBA and Python community.


For more programming tips visit the VBA Tutorials Blog and the Python Tutorials Blog.