0 votes
in VBA by Beginner (20 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 (2.7k 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 (20 points)
edited by
thanks so much  and i'm really sorry i know  too late because some cicumstances  indeed your code is very huge  i apply your code  and give me the error   type mismatch error  it transfer data the column  of import and export,blance stay empty   i hope read my  post

despite  my delaying the highlight error is

Dim strVal As String
by Super Expert (2.7k points)

Changing strVal from a String to a Variant would probably fix the issue. The other option is to change the line

strVal = rngCell.Text


strVal = cStr(rngCell.Text)

by Beginner (20 points)
Thanks  but  doesn't  succeed  it gives  me  error

"Type mismatch"   

Without  any highlight  line of  code
by Super Expert (2.7k points)
The solution I posted assumed your table was entered in columns A through E. The column headers weren't included in the screenshot so I had to guess. I suspect your table is in a different range of columns and you're getting a mismatch error because it's trying to add values in the 5th column and instead of adding numbers, it's trying to add strings and it can't do that. You'll need to change the "A1:E" lines in the dictionary statements if your data isn't presented in columns A through E. If your import/export data isn't in the 5th column of your table, you'll also need to change .Cells(5) to match the correct column number.
by Beginner (20 points)

 the ranges of columns  are the same what  is found my images in above   

sheet1: from  a1:e 

sheet2: from a1:e

sheet3: from a1: g

you can see my file


by Super Expert (2.7k points)
It looks like this is a spreadsheet error and not a macro error. row 128 of SHEET1 has the word "JAP" written in column E instead of a numeric value. It looks like columns D and E were inadvertantly swapped. There also appears to be an empty cell in row 137 column E instead of a 0. Fix these 2 issues and the macro should work fine.

Note: It also looks like Row 204 has a leading space in front of the brand. I didn't write the macro to check for inadvertant leading spaces, so you might want to do a sweep and check for typos like that, either manually or with a macro using the Trim function.
by Beginner (20 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 (2.7k 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 (20 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 (2.7k 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 (20 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 (20 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.

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:

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.