从数组中复制信息

Question

我有这个代码比较两个列表，它运行良好，但我需要复制与某些单元格相关的信息（它们位于填充数组的工作表中每个单元格的右侧）到另一张纸。这可能吗？

这是我的代码：

Option Explicit
Sub RemoveUnwantedText(ByRef theArray As Variant)

Dim theValue As String
Dim i As Long
Dim indexOfComma As Integer
    ' array is created from single-column range of cells
    ' and so has 2 dimensions
    For i = LBound(theArray, 1) To UBound(theArray, 1)
        theValue = CStr(theArray(i, 1))
        indexOfComma = InStr(1, theValue, ",")
        If indexOfComma > 0 Then
            theValue = Trim(Left(theValue, indexOfComma - 1))
        End If
        theArray(i, 1) = theValue
    Next i

End Sub

Private Sub cmdCompare2to1_Click()



Dim sheet1 As Worksheet, sheet2 As Worksheet, sheet3 As Worksheet
Dim lngLastR As Long, lngCnt As Long
Dim var1 As Variant, var2 As Variant, x
Dim rng1 As Range, rng2 As Range


Set sheet1 = Worksheets(1)
Set sheet2 = Worksheets(2)
Set sheet3 = Worksheets(3) ' assumes sheet3 is a blank sheet in your workbook

Application.ScreenUpdating = False

'let's get everything all set up
'sheet3 column headers
sheet3.Range("A1:B1").Value = Array("in1Not2", "in2Not1")

'sheet1 range and fill array
With sheet1

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

    Set rng1 = .Range("A1:A" & lngLastR)
    var1 = rng1

End With

'sheet2 range and fill array
With sheet2

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

    Set rng2 = .Range("A1:A" & lngLastR)
    var2 = rng2

End With

RemoveUnwantedText var1
RemoveUnwantedText var2

'first check sheet1 against sheet2
On Error GoTo NoMatch1
For lngCnt = 1 To UBound(var1)

    x = Application.WorksheetFunction.Match(var1(lngCnt, 1), rng2, False)

Next


'now check sheet2 against sheet1
On Error GoTo NoMatch2
For lngCnt = 1 To UBound(var2)

    x = Application.WorksheetFunction.Match(var2(lngCnt, 1), rng1, False)

Next

On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub

NoMatch1:
    sheet3.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = var1(lngCnt, 1)
    Resume Next


NoMatch2:
    sheet3.Range("B" & sheet3.Rows.Count).End(xlUp).Offset(1) = var2(lngCnt, 1)
    Resume Next


End Sub

修改

好吧我根据我的数据调整了以下答案：

NoMatch1: sheet3.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = var1(lngCnt, 1) 'Reference Cell in Sheet1 column B using lngCnt in the loop and put in column C sheet4.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 1) sheet4.Range("B" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 2) sheet4.Range("C" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 3) sheet4.Range("D" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 4) sheet4.Range("E" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 5) sheet4.Range("F" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 6) sheet4.Range("G" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 7) sheet4.Range("H" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 8) Resume Next

然而......我的情况就是这样。

我有一个列表1，这是一堆公司名称。 我有列表2，这是我所有客户和地址的完整文件。

我的想法是 - ＆gt;比较列表，获取两个列表中公司的名称，仅从列表2中获取两个列表中公司名称的地址信息。

我认为这很接近......我不能完全理解如何做到这一点。

Answer 1

正如我在评论中所说：

是的，使用阵列循环中的位置引用单元格。

如果您在var1(lngCnt, 1)，那么您可以使用类似

的内容

sheet3.Range("C" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet1.Cells(lngCnt, 2)

在此修改中，我将值放在复制的值的右侧：

NoMatch1:
    sheet3.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = var1(lngCnt, 1)
    'Reference Cell in Sheet1 column B using lngCnt in the loop and put in column C
    sheet3.Range("C" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet1.Cells(lngCnt, 2)
    Resume Next


NoMatch2:
    sheet3.Range("B" & sheet3.Rows.Count).End(xlUp).Offset(1) = var2(lngCnt, 1)
    'Reference Cell in Sheet2 column B using lngCnt in the loop and put in column D
    sheet3.Range("D" & sheet3.Rows.Count).End(xlUp).Offset(1) = sheet2.Cells(lngCnt, 2)
    Resume Next

结果：

修改

Sub GetAddressesOnBothLists()
Dim c                             'c will be our iterator
Dim Finder As Range               'Finder will search our range
Dim SearchRangeS1, SearchRangeS2  'These are the ranges to search

'Set the search ranges for Sheet1 and Sheet2
'Here we search column A, but you can use any range you want
Set SearchRangeS1 = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
Set SearchRangeS2 = Sheet2.Range("A1:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)

'Clear Sheet3 for output
Sheet3.Cells.Clear
Sheet3.Range("A1") = "Company Name"
Sheet3.Range("B1") = "Company Address"

'For Each Cell in SearchRangeS1
For Each c In SearchRangeS1
    Set Finder = Nothing
    'Search for the value in SearchRangeS2
    Set Finder = SearchRangeS2.Find(c.Value, LookAt:=xlWhole)
    'If we find the value
    If Not Finder Is Nothing Then
        With Sheet3.Range("A" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row + 1)
            'Output the found value to Sheet3 column A
            .Value = Finder.Value
            'Output the address from Sheet2 in the Cell next to it (B)
            .Offset(0, 1).Value = Finder.Offset(0, 1)
        End With
    End If
Next c
End Sub

使用上述代码的结果：

<强> EDIT2：

这将在Sheet2上返回重复的结果。

请注意，如果Sheet1上有重复项，它将再次返回Sheet2上的所有重复项。

Sub GetAddressesOnBothLists()
Dim c
Dim Finder As Range
Dim DuplicateFinder 'This will store the address of our first Find
Dim SearchRangeS1, SearchRangeS2

Set SearchRangeS1 = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
Set SearchRangeS2 = Sheet2.Range("A1:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)

Sheet3.Cells.Clear
Sheet3.Range("A1") = "Company Name"
Sheet3.Range("B1") = "Company Address"
For Each c In SearchRangeS1
    Set Finder = Nothing
    Set Finder = SearchRangeS2.Find(c.Value, LookAt:=xlWhole)
    If Not Finder Is Nothing Then
        'Store the address of our first find so we know when to stop
        DuplicateFinder = Finder.Address
        Do
            With Sheet3.Range("A" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row + 1)
                .Value = Finder.Value
                .Offset(0, 1).Resize(, 8).Value = Finder.Offset(0, 1).Resize(, 8).Value
            End With
            'Find the next value
            Set Finder = SearchRangeS2.FindNext(Finder)
        'Continue returning results until none are found or we reach our original
        Loop While Not Finder Is Nothing And DuplicateFinder <> Finder.Address
    End If
Next c
End Sub

如果重复值是一个问题，你可以循环遍历Sheet2中的每个单元格而不是Sheet1并搜索Sheet1 - 如果您要做的就是确保在复制Sheet2数据之前Sheet1上存在该值，可以翻转SearchRanges并完全摆脱循环。

该代码在这里：

Sub GetAddressesOnBothLists()
Dim c
Dim Finder As Range
Dim SearchRangeS1, SearchRangeS2
Set SearchRangeS1 = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
Set SearchRangeS2 = Sheet2.Range("A1:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
Sheet3.Cells.Clear
Sheet3.Range("A1") = "Company Name"
Sheet3.Range("B1") = "Company Address"
For Each c In SearchRangeS2
    Set Finder = Nothing
    Set Finder = SearchRangeS1.Find(c.Value, LookAt:=xlWhole)
    If Not Finder Is Nothing Then
        With Sheet3.Range("A" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row + 1)
            .Value = c
            .Offset(0, 1).Resize(, 8).Value = c.Offset(0, 1).Resize(, 8).Value
        End With
    End If
Next c
End Sub