0 votes
in VBA by Beginner (10 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 Beginner (5 points)
Did you try this with Power Query?
by Beginner (10 points)
actually  I would  vba  macro   if it's  possible
0 votes
by Super Expert (2.4k points)

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.

ago by Beginner (10 points)
edited ago 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

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:

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.