• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro extract data from multiple sheets based on matched criteria

I

IKHAN

Member
Hello,

Need assistance with macro to extract data from multiple sheets based on matched criteria and sum up the values.

All vendor data must start from col (C), Below query copies data to other column if no match in first or second sheet.

Hope was able to put my question thru properly..

Attached sample file with output reqd.


Code: 
Sub test()

    Dim c As Range
 
    On Error Resume Next
    For Each c In Range("A3:A10").Cells
   
        With Sheets("Chelsea").Columns("F").Find(What:=c.Value)
            .Offset(, 2).Copy c.Offset(, 2)
            .Offset(, -4).Copy c.Offset(, 3)
        With Sheets("John").Columns("F").Find(What:=c.Value)
            .Offset(, 2).Copy c.Offset(, 4)
            .Offset(, -4).Copy c.Offset(, 5)
        With Sheets("David").Columns("F").Find(What:=c.Value)
            .Offset(, 2).Copy c.Offset(, 6)
            .Offset(, -4).Copy c.Offset(, 7)
           
        End With
       
        End With
       
          End With
    Next c
End Sub
 

Attachments

Hello IKHAN

After checking you Test file..Which is working fine..Please let us know what else you are expecting from the macro...Happy to help you.
 
hi

Macro above doesn't total in column B and also all VENDOR data must start from column C ( If you have a look at sample file attached line 5 and line 8 starts from column E and G .
 
Here's how I read your problem.
Code: 
Sub test()
    Dim ws As Worksheet, a, i As Long, ii As Long, dic As Object, w
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For Each ws In Worksheets
        If ws.Name <> "output" Then
            a = ws.Range("b6", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, 9).Value
            For i = 1 To UBound(a, 1)
                If (a(i, 5) <> "") * (a(i, 9) <> "") Then
                    If Not dic.exists(a(i, 5)) Then
                        ReDim w(1 To 2)
                        Set w(1) = CreateObject("System.Collections.ArrayList")
                    Else
                        w = dic(a(i, 5))
                    End If
                    w(1).Add Array(a(i, 7), a(i, 1)): w(2) = w(2) + a(i, 9)
                    dic(a(i, 5)) = w
                End If
            Next
        End If
    Next
    ReDim a(1 To dic.Count + 1, 1 To 4)
    a(1, 1) = "Fruits": a(1, 2) = "Total": a(1, 3) = "Vendor1": a(1, 4) = "Status"
    For i = 0 To dic.Count - 1
        a(i + 2, 1) = StrConv(dic.keys()(i), 3)
        If UBound(a, 2) < dic.Items()(i)(1).Count * 2 + 2 Then
            ReDim Preserve a(1 To UBound(a, 1), 1 To dic.Items()(i)(1).Count * 2 + 2)
        End If
        For ii = 0 To dic.Items()(i)(1).Count - 1
            a(i + 2, 2) = a(i + 2, 2) + dic.Items()(i)(2)
            a(i + 2, ii * 2 + 3) = dic.Items()(i)(1)(ii)(0)
            a(i + 2, ii * 2 + 4) = dic.Items()(i)(1)(ii)(1)
        Next
    Next
    With Sheets("output").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.ClearContents
        .Value = a
        If .Columns.Count > 3 Then
            .Cells(1, 3).Resize(, 2).AutoFill .Cells(1, 3).Resize(, 2).Resize(, .Columns.Count - 2)
        End If
    End With
End Sub
 
@jindon .. Thank you for assisting. After running above macro found that..

1. Total of each product is incorrect ( Must add total of each product(fruit) from all sheets.

2. Header to start from ROW 2 in "output" sheet

3. Attached is a sample file with only 3 sheets, eventually -i 'll have 10 sheets(vendors) , So if you can highlight or summarize the code so that i can modify the code to add more sheets in future.

Again Thanks for your help...
 
Change to
Code: 
Sub test()
    Dim ws As Worksheet, a, i As Long, ii As Long, dic As Object, w
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For Each ws In Worksheets
        If ws.Name <> "output" Then
            a = ws.Range("b6", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, 9).Value
            For i = 1 To UBound(a, 1)
                If (a(i, 5) <> "") * (a(i, 9) <> "") Then
                    If Not dic.exists(a(i, 5)) Then
                        ReDim w(1 To 2)
                        Set w(1) = CreateObject("System.Collections.ArrayList")
                    Else
                        w = dic(a(i, 5))
                    End If
                    w(1).Add Array(a(i, 7), a(i, 1))
                    w(2) = w(2) + a(i, 9)
                    dic(a(i, 5)) = w
                End If
            Next
        End If
    Next
    ReDim a(1 To dic.Count + 1, 1 To 4)
    a(1, 1) = "Fruits": a(1, 2) = "Total": a(1, 3) = "Vendor1": a(1, 4) = "Status"
    For i = 0 To dic.Count - 1
        a(i + 2, 1) = StrConv(dic.keys()(i), 3)
        a(i + 2, 2) = dic.Items()(i)(2)
        If UBound(a, 2) < dic.Items()(i)(1).Count * 2 + 2 Then
            ReDim Preserve a(1 To UBound(a, 1), 1 To dic.Items()(i)(1).Count * 2 + 2)
        End If
        For ii = 0 To dic.Items()(i)(1).Count - 1
            a(i + 2, ii * 2 + 3) = dic.Items()(i)(1)(ii)(0)
            a(i + 2, ii * 2 + 4) = dic.Items()(i)(1)(ii)(1)
        Next
    Next
    With Sheets("output").Range("a1").Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Value = a
        If .Columns.Count > 3 Then
            .Cells(2, 3).Resize(, 2).AutoFill .Cells(2, 3).Resize(, 2).Resize(, .Columns.Count - 2)
        End If
    End With
End Sub
 
@jindon .. Was able to modify the code for moved columns

Require additional fields to be added to output field - please see attached file.

Thanks for your help



Code: 
Sub test()
    Dim ws As Worksheet, a, i As Long, ii As Long, dic As Object, w
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For Each ws In Worksheets
        If ws.Name <> "output" Then
            a = ws.Range("b6", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, 10).Value
            For i = 1 To UBound(a, 1)
                If (a(i, 5) <> "") * (a(i, 10) <> "") Then
                    If Not dic.exists(a(i, 5)) Then
                        ReDim w(1 To 2)
                        Set w(1) = CreateObject("System.Collections.ArrayList")
                    Else
                        w = dic(a(i, 5))
                    End If
                    w(1).Add Array(a(i, 8), a(i, 1))
                    w(2) = w(2) + a(i, 10)
                    dic(a(i, 5)) = w
                End If
            Next
        End If
    Next
    ReDim a(1 To dic.Count + 1, 1 To 4)
    a(1, 1) = "Fruits": a(1, 2) = "Total": a(1, 3) = "Vendor1": a(1, 4) = "Status"
    For i = 0 To dic.Count - 1
        a(i + 2, 1) = StrConv(dic.keys()(i), 3)
        a(i + 2, 2) = dic.Items()(i)(2)
        If UBound(a, 2) < dic.Items()(i)(1).Count * 2 + 2 Then
            ReDim Preserve a(1 To UBound(a, 1), 1 To dic.Items()(i)(1).Count * 2 + 2)
        End If
        For ii = 0 To dic.Items()(i)(1).Count - 1
            a(i + 2, ii * 2 + 3) = dic.Items()(i)(1)(ii)(0)
            a(i + 2, ii * 2 + 4) = dic.Items()(i)(1)(ii)(1)
        Next
    Next
    With Sheets("output").Range("a1").Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Value = a
        If .Columns.Count > 3 Then
            .Cells(2, 3).Resize(, 2).AutoFill .Cells(2, 3).Resize(, 2).Resize(, .Columns.Count - 2)
        End If
    End With
End Sub
 

Attachments

Last edited:
Code: 
Sub test()
    Dim ws As Worksheet, a, i As Long, ii As Long, iii As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For Each ws In Worksheets
        If ws.Name <> "output" Then
            a = ws.Range("b6", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, 10).Value
            For i = 1 To UBound(a, 1)
                If (a(i, 5) <> "") * (a(i, 10) <> "") Then
                    If Not dic.exists(a(i, 5)) Then
                        Set dic(a(i, 5)) = CreateObject("System.Collections.ArrayList")
                    End If
                    dic(a(i, 5)).Add Array(a(i, 8), a(i, 1), a(i, 10))
                End If
            Next
        End If
    Next
    ReDim a(1 To dic.Count + 1, 1 To 5)
    a(1, 1) = "Fruits": a(1, 2) = "Total": a(1, 3) = "Vendor1"
    a(1, 4) = "Status": a(1, 5) = "breakdown"
    For i = 0 To dic.Count - 1
        a(i + 2, 1) = StrConv(dic.keys()(i), 3)
        If UBound(a, 2) < dic.items()(i).Count * 3 + 3 Then
            ReDim Preserve a(1 To UBound(a, 1), 1 To dic.items()(i).Count * 3 + 3)
        End If
        For ii = 0 To dic.items()(i).Count - 1
            a(i + 2, 2) = a(i + 2, 2) + dic.items()(i)(ii)(2)
            For iii = 0 To 2
                a(i + 2, ii * 3 + 3 + iii) = dic.items()(i)(ii)(iii)
        Next iii, ii
    Next
    With Sheets("output").Range("a1").Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Value = a
        If .Columns.Count > 5 Then
            .Cells(2, 3).Resize(, 3).AutoFill .Cells(2, 3).Resize(, 2).Resize(, .Columns.Count - 3)
        End If
    End With
End Sub
 
@jindon
Hello,
Have couple more request to add to current code

1. Total for all months in column B - Attached test file and sample output in row 17 to 24
2. extract report by vendor (Have dropdown in cell B29 ,C29 and D29 and sample output file in row 30 to 42

drop down has vendor names , current month\last 3 months\3 month forcast\yearly for each vendor and POC

POC to extract data from column G11:G20 and K11 :K20 for selected vendor

Not sure if all his requests can be done thru excel..

Thanks,Very much appreciated ...
 

Attachments

Not sure
Code: 
Sub test()
    Dim ws As Worksheet, a, i As Long, ii As Long, iii As Long, dic As Object, temp
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For Each ws In Worksheets
        If (ws.Name <> "output") * (ws.Name <> "Vendor") Then
            a = ws.Range("b6", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, ws.Cells.SpecialCells(11).Column).Value
            For i = 1 To UBound(a, 1)
                If (a(i, 5) <> "") * (a(i, 10) <> "") Then
                    If Not dic.exists(a(i, 5)) Then
                        Set dic(a(i, 5)) = CreateObject("System.Collections.ArrayList")
                    End If
                    For ii = 12 To UBound(a, 2) Step 3
                        temp = Application.Sum(temp, a(i, ii))
                    Next
                    dic(a(i, 5)).Add Array(a(i, 8), a(i, 1), a(i, 10), temp): temp = 0
                End If
            Next
        End If
    Next
    ReDim a(1 To dic.Count + 1, 1 To 6)
    a(1, 1) = "Fruits": a(1, 2) = "Total for all months": a(1, 3) = "Total for current month"
    a(1, 4) = "Vendor1": a(1, 5) = "Status": a(1, 6) = "breakdown"
    For i = 0 To dic.Count - 1
        a(i + 2, 1) = StrConv(dic.keys()(i), 3)
        If UBound(a, 2) < dic.items()(i).Count * 3 + 4 Then
            ReDim Preserve a(1 To UBound(a, 1), 1 To dic.items()(i).Count * 3 + 4)
        End If
        For ii = 0 To dic.items()(i).Count - 1
            a(i + 2, 2) = a(i + 2, 2) + dic.items()(i)(ii)(3)
            a(i + 2, 3) = a(i + 2, 3) + dic.items()(i)(ii)(2)
            For iii = 0 To 2
                a(i + 2, ii * 3 + 4 + iii) = dic.items()(i)(ii)(iii)
        Next iii, ii
    Next
    With Sheets("output").Range("a1").Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Value = a
        If .Columns.Count > 6 Then
            .Cells(2, 4).Resize(, 3).AutoFill .Cells(2, 4).Resize(, 2).Resize(, .Columns.Count - 4)
        End If
    End With
End Sub
 
@ Jindon..

Thank you much ..Simply awesome coding.

Part 2 - Doesn't work. Tried to understand your code..It's v hi tech for me.

Basically, Need to extract columns based on vendor name and month

Attached sample file for ref.

Thanks again for your time.
 

Attachments

@jindon

Hi
Columns have been changed and added new columns from previous ask. Have made few changes and was able to fix few requirements

Require assistance with below

1. New column "Variance" is reqd. in Output sheet after "breakdown" column for each vendor.

2.Have created dropdown list in output sheet in cell "C1" and calling months thru macros

when month is selected, having issues with calculations

"Fruits" and "Total for Year" is not being updated in output sheet for previous months.

example : If "feb" is selected - row 5 - "total for year" should add upto 15

Thanks in advance...

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

Dim allColumns As Range
   
      If Not Intersect(Target, Range("C1")) Is Nothing Then
        If Target.Value = "Jan" Then
       
        Call Jan
       
        ElseIf Target.Value = "Feb" Then
       
        Call Feb
       
        End If
          End If
End Sub


Sub Jan()
    Dim ws As Worksheet, a, i As Long, ii As Long, iii As Long, dic As Object, temp
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For Each ws In Worksheets
        If (ws.Name <> "output") * (ws.Name <> "Vendor") Then
            a = ws.Range("b6", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, ws.Cells.SpecialCells(11).Column).Value
            For i = 1 To UBound(a, 1)
                If (a(i, 5) <> "") * (a(i, 13) <> "") Then
                    If Not dic.exists(a(i, 5)) Then
                        Set dic(a(i, 5)) = CreateObject("System.Collections.ArrayList")
                    End If
                    For ii = 13 To UBound(a, 2) Step 3
                        temp = Application.Sum(temp, a(i, ii))
                    Next
                    dic(a(i, 5)).Add Array(a(i, 8), a(i, 1), a(i, 13), temp): temp = 0
                End If
            Next
        End If
    Next
    ReDim a(1 To dic.Count + 1, 1 To 6)
    a(1, 1) = "Fruits": a(1, 2) = "Total for year": a(1, 3) = "Total for above selected month"
    a(1, 4) = "Vendor1": a(1, 5) = "Status": a(1, 6) = "breakdown"
    For i = 0 To dic.Count - 1
        a(i + 2, 1) = StrConv(dic.keys()(i), 3)
        If UBound(a, 2) < dic.items()(i).Count * 3 + 4 Then
            ReDim Preserve a(1 To UBound(a, 1), 1 To dic.items()(i).Count * 3 + 4)
        End If
        For ii = 0 To dic.items()(i).Count - 1
            a(i + 2, 2) = a(i + 2, 2) + dic.items()(i)(ii)(3)
            a(i + 2, 3) = a(i + 2, 3) + dic.items()(i)(ii)(2)
            For iii = 0 To 2
                a(i + 2, ii * 3 + 4 + iii) = dic.items()(i)(ii)(iii)
        Next iii, ii
    Next
    With Sheets("output").Range("a1").Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Value = a
        If .Columns.Count > 6 Then
            .Cells(2, 4).Resize(, 3).AutoFill .Cells(2, 4).Resize(, 2).Resize(, .Columns.Count - 4)
        End If
    End With
End Sub

Sub Feb()
    Dim ws As Worksheet, a, i As Long, ii As Long, iii As Long, dic As Object, temp
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For Each ws In Worksheets
        If (ws.Name <> "output") * (ws.Name <> "Vendor") Then
            a = ws.Range("b6", ws.Range("b" & Rows.Count).End(xlUp)).Resize(, ws.Cells.SpecialCells(11).Column).Value
            For i = 1 To UBound(a, 1)
                If (a(i, 5) <> "") * (a(i, 18) <> "") Then
                    If Not dic.exists(a(i, 5)) Then
                        Set dic(a(i, 5)) = CreateObject("System.Collections.ArrayList")
                    End If
                    For ii = 13 To UBound(a, 2) Step 3
                        temp = Application.Sum(temp, a(i, ii))
                    Next
                    dic(a(i, 5)).Add Array(a(i, 8), a(i, 1), a(i, 18), temp): temp = 0
                End If
            Next
        End If
    Next
    ReDim a(1 To dic.Count + 1, 1 To 6)
    a(1, 1) = "Fruits": a(1, 2) = "Total for year": a(1, 3) = "Total for above selected month"
    a(1, 4) = "Vendor1": a(1, 5) = "Status": a(1, 6) = "breakdown"
    For i = 0 To dic.Count - 1
        a(i + 2, 1) = StrConv(dic.keys()(i), 3)
        If UBound(a, 2) < dic.items()(i).Count * 3 + 4 Then
            ReDim Preserve a(1 To UBound(a, 1), 1 To dic.items()(i).Count * 3 + 4)
        End If
        For ii = 0 To dic.items()(i).Count - 1
            a(i + 2, 2) = a(i + 2, 2) + dic.items()(i)(ii)(3)
            a(i + 2, 3) = a(i + 2, 3) + dic.items()(i)(ii)(2)
            For iii = 0 To 2
                a(i + 2, ii * 3 + 4 + iii) = dic.items()(i)(ii)(iii)
        Next iii, ii
    Next
    With Sheets("output").Range("a1").Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Value = a
        If .Columns.Count > 6 Then
            .Cells(2, 4).Resize(, 3).AutoFill .Cells(2, 4).Resize(, 2).Resize(, .Columns.Count - 4)
        End If
    End With
End Sub
 

Attachments

You must log in or register to reply here.
Back
Top