Блог

Ищу еще немного помощи, пожалуйста. Я был здесь месяц назад, когда RiskyPenguin дал мне отличный код. Я хотел бы добавить к этому еще кое-что.

Это та часть, которая работает: поэтому, если электронная таблица «счет» (лист 5), если ячейка G4 (например, I111) соответствует любым данным в первом столбце электронной таблицы «доходы» (лист 1) (начиная со строки 6), то соответствующие данные в столбцах 2, 3, 8 и 9 будут скопированы в электронную таблицу «счет» в столбцах 2, 3, 4 и 5 (начиная со строки 13).

 Sub FindAndCopyData2()
    Dim shData As Worksheet, shReport As Worksheet
    Set shData = Sheet1
    Set shReport = Sheet6
    
    Dim strInvoceNumber As String
    strInvoceNumber = shReport.Cells(4, "E").Value
    
    Dim intLastRow As Integer
    intLastRow = shData.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim intReportRow As Integer
    intReportRow = 13
    
    shReport.Range("B13:E20").ClearContents
    
    Dim i As Integer
    For i = 1 To intLastRow
        If shData.Cells(i, 1).Value2 = strInvoceNumber Then
            shReport.Cells(intReportRow, 2).Value2 = shData.Cells(i, 3).Value2
            shReport.Cells(intReportRow, 3).Value2 = shData.Cells(i, 4).Value2
            shReport.Cells(intReportRow, 4).Value2 = shData.Cells(i, 8).Value2
            shReport.Cells(intReportRow, 5).Value2 = shData.Cells(i, 9).Value2
            
            intReportRow = intReportRow   1
        End If
    Next i
    
End Sub
 

Затем я хотел бы (надеюсь, используя тот же поиск)

Возьмите электронную таблицу «счет» (лист 5), если ячейка G4 (например, I111) соответствует любым данным во втором столбце электронной таблицы «расходы» (лист 2) (начиная со строки 11), то соответствующие данные в столбцах 3, 5 и 7 будут скопированы в электронную таблицу «счет» в столбцах 2, 4 и 6 (начиная со строки 13).

Возможно ли это или это должно быть отдельной частью программирования? Большое спасибо за любые советы.

Предполагая, что это может быть полезно для других, я сделал из этого функцию и переработал исходный код для обработки копии в памяти. Я настроил ваш первый поиск, поэтому вам просто нужно отредактировать переменные, чтобы получить второй поиск:

 Option Explicit
''''''''''''''''''''''''''''''''''''''
''Main Sub
''''''''''''''''''''''''''''''''''''''''''''''''''
    Sub main()
        'Set some vars
        Dim sourceArr, targetArr, sourceCls, targetCls, sourceStartRw As Long, targetStartRw As Long, dict As Object, j As Long, sourceLookupCl As Long, Matchkey As Long
        ''''''''''''''''''''''''''''''''''''''
        ''Lookup 1
        ''''''''''''''''''''''''''''''''''''''''''''''''''
        Matchkey = Sheet5.Range("G4").Value2 'lookupKey
        sourceCls = Split("2,3,8,9 ", ",") 'Columns to copy from
        targetCls = Split("2,3,4,5", ",") 'Columns to copy to
        sourceStartRw = 6
        targetStartRw = 13
        sourceLookupCl = 1 'matching column
        
        'get data in memory = array
        sourceArr = Sheet1.Range("A1").CurrentRegion.Value2
        
        'call our function
        targetArr = reorder(sourceArr, sourceCls, targetCls, sourceStartRw, sourceLookupCl, Matchkey)
        
        'dump to sheet
        With Sheet5
            .Range(.Cells(targetStartRw, 1), .Cells(UBound(targetArr)   targetStartRw - 1, UBound(targetArr, 2))).Value2 = targetArr
        End With
        
        ''''''''''''''''''''''''''''''''''''''
        ''Lookup 2 => change source and target cols to your need
        ''''''''''''''''''''''''''''''''''''''''''''''''''
        Matchkey = Sheet5.Range("G4").Value2
        sourceCls = Split("2,3,8,9 ", ",")
        targetCls = Split("2,3,4,5", ",")
        sourceStartRw = 6
        targetStartRw = 13 'must be the same as previous lookup if you want to keep the targetArr from previous lookups
        sourceLookupCl = 1
        
        'get data in memory = array
        sourceArr = Sheet1.Range("A1").CurrentRegion.Value2
        
        'call our function keeping the data from the first lookup
        targetArr = reorder(sourceArr, sourceCls, targetCls, sourceStartRw, sourceLookupCl, Matchkey, targetArr)
        
        'dump to sheet
        With Sheet5
            .Range(.Cells(targetStartRw, 1), .Cells(UBound(targetArr)   targetStartRw - 1, UBound(targetArr, 2))).Value2 = targetArr
        End With
    End Sub

''''''''''''''''''''''''''''''''''''''
''Supporting function
''''''''''''''''''''''''''''''''''''''''''''''''''
    Private Function reorder(sourceArr, sourceCls, targetCls, sourceStartRw As Long, sourceLookupCl As Long, Matchkey As Long, Optional targetArr) As Variant
        Dim dict As Object, j As Long
        'if the target array overlaps the previous lookups pass it to the function
        If IsMissing(targetArr) Then
            ReDim targetArr(1 To UBound(sourceArr), 1 To UBound(sourceArr, 2))
        End If
        
        'build a dict to compare quickly
        Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
        For j = 1 To UBound(sourceArr) 'traverse source
            dict(sourceArr(j, sourceLookupCl)) = Empty
        Next j
        
        'check if key exists in dict and copy data
        Dim i As Long, ii As Long ': ii = 1
        If dict.Exists(Matchkey) Then
            For j = sourceStartRw To UBound(sourceArr)
                For i = 1 To UBound(sourceArr, 2)
                    If i = sourceCls(ii) Then
                        targetArr(j - sourceStartRw   1, targetCls(ii)) = sourceArr(j, i)
                        ii = IIf(ii < UBound(sourceCls), ii   1, ii)
                    End If
                Next i
                ii = 0
            Next j
        End If
        
        reorder = targetArr
    End Function