How to match and extract data using multiple criteria from 2 worksheets?

问题

I have 2 worksheets, Sheet1 and Sheet2, Sheet1 is empty save for product numbers. I have to extract the data from Sheet2 into Sheet1 to give a clearer overview of it.

In Sheet1 the regions are differentiated as AP(Asia Pacific), EMEA (Europe & Middle East) and NA (North America), and in Sheet2 they are differentiated as IN (India), DE (Germany) and US (USA) My sheets look like follows:

Sheet1

`       Air             |Ocean      
 Number AP  EMEA    NA  |AP EMEA    NA
 1                      |
 2                      |
 3                      |
 4                      |              `

Sheet2

 NUMBER GEO_CODE    FREIGHT_TYPE    FREIGHT_COST
 1          IN          Air             1
 1          IN          Ocean           2
 1          US          Air             6
 1          US          Ocean           9
 1          DE          Air             6
 1          DE          Ocean           3
 2          IN          Air             1
 2          IN          Ocean           2
 2          US          Air             7
 2          US          Ocean           8
 2          DE          Air             5
 2          DE          Ocean           4
 3          IN          Air             1
 3          IN          Ocean           2
 3          US          Air             6
 3          US          Ocean           9
 3          DE          Air             6
 3          DE          Ocean           3

I have already tried 'If Then' embedded into a 'Do Until Loop', while this seems to work in debugging i believe my data set is too large and therefore crashes the Program.
Note that there is no # 4 from 'Sheet1' in 'Sheet2', as 'Sheet2' is not complete.

Dim PN1 As Variant
Dim PN As Variant
Dim X As Integer
Dim Y As Integer
Dim Country As Variant
Dim Plant As Variant
Dim Freight As Variant
Dim FreightCost As Variant


Dim Lookuprng As Range
Dim Result As Range
Dim LibRng As Range

Dim Library As Workbook
Dim CostTape As Workbook



Set Library = Workbooks("List2.xlsm")
Set LibRng =     Workbooks("List2.xlsm").Worksheets("Sheet1").Range("A1:Z10000")
Set Lookuprng = Workbooks("List2.xlsm").Worksheets("Sheet2").Range("A1:Z10000")

Library.Activate
X = 2
Y = 3
PN = Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X).Value
PN1 = Workbooks("List2.xlsm").Worksheets("Sheet1").Range("A" & Y).Value






Do Until IsEmpty(PN1)
On Error Resume Next
PN = Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X).Value
PN1 = Workbooks("List2.xlsm").Worksheets("Sheet1").Range("A" & Y).Value
Country = Workbooks("list2.xlsm").Worksheets("Sheet2").Range("F" & X).Value
Freight = Workbooks("list2.xlsm").Worksheets("Sheet2").Range("I" & X).Value

If PN = PN1 Then
    If Country = "IN" Then
            If Freight = "AIR" Then
            FreightCost = Workbooks("List2.xlsm").Worksheets("Sheet2").Range("M" & X)
            Workbooks("List2.xlsm").Worksheets("Sheet1").Range("O" & Y).Value = FreightCost.Value
            X = X + 1
            If PN <> Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X + 1).Value Then
                Y = Y + 1
            End If
        ElseIf Freight = "OCEAN" Then
            FreightCost = Workbooks("List2.xlsm").Worksheets("Sheet2").Range("M" & X)
            Workbooks("List2.xlsm").Worksheets("Sheet1").Range("R" & Y).Value = FreightCost.Value
        X = X + 1
            If PN <> Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X + 1).Value Then
                Y = Y + 1
            End If
        ElseIf Freight <> "OCEAN" And Freight <> "AIR" Then
            X = X + 1
             If PN <> Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X + 1).Value Then
                Y = Y + 1
            End If
        End If
    End If
End If


If PN = PN1 Then
    If Country = "US" Then
            If Freight = "AIR" Then
            FreightCost = Workbooks("List2.xlsm").Worksheets("Sheet2").Range("M" & X)
            Workbooks("List2.xlsm").Worksheets("Sheet1").Range("Q" & Y).Value = FreightCost.Value
        X = X + 1
            If PN <> Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X + 1).Value Then
                Y = Y + 1
                End If
        ElseIf Freight = "OCEAN" Then
            FreightCost = Workbooks("List2.xlsm").Worksheets("Sheet2").Range("M" & X)
            Workbooks("List2.xlsm").Worksheets("Sheet1").Range("T" & Y).Value = FreightCost.Value
            X = X + 1
            If PN <> Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X + 1).Value Then
                Y = Y + 1
            End If
        ElseIf Freight <> "OCEAN" And Freight <> "AIR" Then
            X = X + 1
             If PN <> Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X + 1).Value Then
                Y = Y + 1
            End If
        End If
    End If
End If

If PN = PN1 Then
    If Country = "DE" Then
        If Freight = "AIR" Then
            FreightCost = Workbooks("List2.xlsm").Worksheets("Sheet2").Range("M" & X)
            Workbooks("List2.xlsm").Worksheets("Sheet1").Range("P" & Y).Value = FreightCost.Value
            X = X + 1
            If PN <> Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X + 1).Value Then
                Y = Y + 1
            End If
        ElseIf Freight = "OCEAN" Then
            FreightCost = Workbooks("List2.xlsm").Worksheets("Sheet2").Range("M" & X)
            Workbooks("List2.xlsm").Worksheets("Sheet1").Range("S" & Y).Value = FreightCost.Value
            X = X + 1
            If PN <> Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X + 1).Value Then
                Y = Y + 1
            End If
        ElseIf Freight <> "OCEAN" And Freight <> "AIR" Then
            X = X + 1
             If PN <> Workbooks("list2.xlsm").Worksheets("Sheet2").Range("A" & X + 1).Value Then
                Y = Y + 1
            End If
        End If
    End If
End If

If PN <> PN1 Then
    X = X + 1
End If
Loop

As stated before, my code works in debugging mode, until i get to a NUMBER which is not present on Sheet2.
I also believe that my code not being the most efficient, it sends my PC crashing when I run it.

Expected results: Have the correct Freight Cost in Sheet1 based on Sheet2 entries

_______Air |Ocean Number AP EMEA NA |AP EMEA NA 1 1 6 6 |2 3 9 2 1 5 7 |2 4 8 3 1 6 6 |2 3 9 4 (Empty since no data)|(Empty since no data)

Any help would be greatly appreciated!

回答1:

I know you posted a VBA code, but in case it works for you, I made up a non-VBA solution, with normal Excel Formulas. You can find the value you want just using SUMIFS and IFS combined.

More about SUMIFS

I made the data like this:

Sheet2:

In Sheet1 I got:

The formula I've used for range B4:D7, starting at B4 (Air range) is:=SUMIFS(Sheet2!$D$2:$D$19;Sheet2!$A$2:$A$19;Sheet1!$A4;Sheet2!$B$2:$B$19;IF(B$3="AP";"IN";IF(B$3="EMEA";"DE";"US"));Sheet2!$C$2:$C$19;"AIR")

The formula I've used for range E4:G7, starting at E4 (Ocean Range) is:

=SUMIFS(Sheet2!$D$2:$D$19;Sheet2!$A$2:$A$19;Sheet1!$A4;Sheet2!$B$2:$B$19;IF(B$3="AP";"IN";IF(B$3="EMEA";"DE";"US"));Sheet2!$C$2:$C$19;"OCEAN")

Both formulas are the same, the only thing that changes is the third criteria (Air/Ocean)

You could drag down and if you got thousands of rows, paste values after using formula.

Hope this helps.

UPDATE 2: OP needs an VBA solution. We can do exactly the same than previous, but as VBA. We can use same function and loop trough all columns and rows. The code I'm posting is adapted exactly to how I've created the data sample (row and column numbers and data position), so you need to fix the code to adap it to how your data is stored.

Sub test()
Application.ScreenUpdating = False
Dim i As Long
Dim ZZ As Long
Dim wkS As Worksheet 'Source
Dim wkD As Worksheet 'Destiny

Set wkD = ThisWorkbook.Worksheets("Sheet1")
Set wkS = ThisWorkbook.Worksheets("Sheet2")

Dim RNumbers As Range 'Range of numbers
Dim RGeoCodes As Range 'Range of GeoCodes
Dim RTypes As Range 'Range of Freight_Types
Dim RFreights As Range 'Range of Freight_Costs

Dim LastRow As Long 'lastrow of data in Sheet2

LastRow = wkS.Range("A" & wkS.Rows.Count).End(xlUp).Row

Set RNumbers = wkS.Range("A2:A" & LastRow)
Set RGeoCodes = wkS.Range("B2:B" & LastRow)
Set RTypes = wkS.Range("C2:C" & LastRow)
Set RFreights = wkS.Range("D2:D" & LastRow)

Dim TextCriteria As String
Dim ThisZone As String

For ZZ = 2 To 7 Step 1 'in my example, data starts at column 2

    i = 4 'in my example, data starts at row 4

    'we get if it's AIR or OCEAN
    Select Case wkD.Cells(i, ZZ).Column
        Case 2 To 4 'columns B,C,D
            TextCriteria = "Air"
        Case 5 To 7 'Columns E,F,G
            TextCriteria = "Ocean"
    End Select

    'We get the zone to sumup
    Select Case UCase(wkD.Cells(3, ZZ).Value) 'in my example, zones are always in row 3
        Case "AP"
            ThisZone = "IN"
        Case "EMEA"
            ThisZone = "DE"
        Case "NA"
            ThisZone = "US"
    End Select

    'We loop with a sumup
    Do Until wkD.Range("A" & i) = ""
        wkD.Cells(i, ZZ).Value = Application.WorksheetFunction.SumIfs(RFreights, RNumbers, wkD.Range("A" & i).Value, RGeoCodes, ThisZone, RTypes, TextCriteria)
        i = i + 1
    Loop
Next ZZ

Application.ScreenUpdating = True

End Sub

I've uploaded a file sample to my Gdrive, with formulas and macro version, in case you want to check something.

https://drive.google.com/open?id=1RWhJy99lTVcFjsIvAb0F2XMkX4fw9SNx

Hope this helps and you can adapt this to your needs.

来源：https://stackoverflow.com/questions/57850088/how-to-match-and-extract-data-using-multiple-criteria-from-2-worksheets

标签

excel

vba

data-manipulation