如何从两张不同的纸张中搜索数据并将它们复制到第三张纸上？

Question

Excel表格的布局

问题：

我必须从两张纸的第一列找到所有字符串的超集。这些可以存在于一张或两张纸中。根据存在的字符串，将该字符串复制到第三个工作表。然后从一个或两个工作表中复制下一列中的数据。然后找出差异。重复。如果两个工作表中都存在字符串，则此代码有效。如果第一列中的字符串不存在于一个或两个中，我如何使其工作？我想要包括两张表中的所有数据。

这是代码：

Sub Macro5()
'
' Macro5 Macro
'

'
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet

Dim coli As Double
Dim Coli3 As Double
Dim rowy As Double

Dim numCols As Double
Dim startRow As Double
Dim lastRow As Double

Dim dict As Scripting.Dictionary

startRow = 6 'assuming data starts here
Coli3 = 2 ' start the columns out on ws3

Set ws1 = ThisWorkbook.Worksheets("sheet1")
Set ws2 = ThisWorkbook.Worksheets("sheet2")
Set ws3 = ThisWorkbook.Worksheets("sheet3")

Application.ScreenUpdating = False

ws3.Cells.Clear


'ws1.Range("A1").EntireColumn.Copy Destination:=ws3.Range("A1")

'Find how many columns there are in sheet1 based on data in row 1
numCols = ws1.Cells(7, Columns.Count).End(xlToLeft).Column
For coli = 2 To numCols
    'Find last Data row in the given column in sheet1
    lastRow = ws1.Cells(ws1.Rows.Count, coli).End(xlUp).Row

    For rowy = 6 To lastRow
        'perform calculation and place in the right spot on sheet 3
        If rowy = "6" Then
            ws3.Cells(rowy, Coli3) = ws1.Cells(rowy, coli) & "-sheet1" ' copy sheet 1 to the right spot of sheet 3
            ws3.Cells(rowy, Coli3 + 1) = ws2.Cells(rowy, coli) & "-sheet2" 'copy sheet 2 to the right spot of sheet 3
            ws3.Cells(rowy, Coli3 + 2) = "Difference"
        Else
            If ws1.Cells(rowy, 1) = ws2.Cells(rowy, 1) Then
                ws3.Cells(rowy, 1) = ws1.Cells(rowy, 1)
                ws3.Cells(rowy, Coli3) = Format(ws1.Cells(rowy, coli).Value, "#,##0") ' copy sheet 1 to the right spot of sheet 3
                ws3.Cells(rowy, Coli3 + 1) = Format(ws2.Cells(rowy, coli).Value, "#,##0") 'copy sheet 2 to the right spot of sheet 3
                ws3.Cells(rowy, Coli3 + 2) = Format((ws1.Cells(rowy, coli).Value) - (ws2.Cells(rowy, coli).Value), "#,##0")
            Else
                ws3.Cells(rowy, 1) = ws1.Cells(rowy, 1)
                ws3.Cells(rowy, Coli3) = Format(ws1.Cells(rowy, coli).Value, "#,##0") ' copy sheet 1 to the right spot of sheet 3
                ws3.Cells(rowy, Coli3 + 1).Value = 0 'copy sheet 2 to the right spot of sheet 3
                ws3.Cells(rowy, Coli3 + 2) = Format((ws1.Cells(rowy, coli).Value) - (ws2.Cells(rowy, coli).Value), "#,##0")
            End If
        End If

    Next rowy ' move to the next row on ws1, ws2, ws3

    'Since we are placing 3 cols at a time in sheet 3 we increment differently
    Coli3 = Coli3 + 3 '1 becomes 4, 4 becomes 7, 7 becomes 10 and so on

Next coli 'move to next column on ws1, ws2


End Sub

请协助。

Answer 1

试一试。策略是在缓冲区中收集所有唯一的字符串值，并将它们的行值存储在索引缓冲区中（假设一个字符串在一个工作表上只出现一次）。然后从索引缓冲区中获取所有行值，并将该行中的值复制到ws3。 N.B。：我将循环和lastrow计数器的类型替换为long。

Sub Macro5()
'
' Macro5 Macro
'

'
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet

Dim coli As Long    
Dim Coli3 As Long 
Dim rowy As Long    

Dim numCols As Long    
Dim lastRow1 As Long    ' last row on sheet1 in the actual data column
Dim lastRow2 As Long    ' last row on sheet2 in the actual data column
Dim r1stSheet As Range  ' string column range on sheet1
Dim r2ndSheet As Range  ' string column range on sheet2
Dim rFnd As Range       ' aux for search

Const MAXROW = 100      ' max number of rows
Const HDRROW = 6        ' row where the header is
Dim aStr(1 To MAXROW) As String    ' strings in col1
Dim aNdx(1 To MAXROW, 1 To 2) As Long  ' col1: row on sheet1 or 0, col2: row on sheet2 or 0
Dim iCnt As Long        ' last valid entry in aNdx

' Dim dict As Scripting.Dictionary

startRow = 6 'assuming data starts here
Coli3 = 2 ' start the columns out on ws3

Set ws1 = ThisWorkbook.Worksheets("sheet1")
Set ws2 = ThisWorkbook.Worksheets("sheet2")
Set ws3 = ThisWorkbook.Worksheets("sheet3")

' Application.ScreenUpdating = False

ws3.Cells.Clear

' make a unique list of all strings on sheet1 and sheet2

lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
Set r1stSheet = Range(ws1.Cells(6, 1), ws1.Cells(lastRow1, 1))
Set r2ndSheet = Range(ws2.Cells(6, 1), ws2.Cells(lastRow2, 1))
iCnt = 0

For rowy = HDRROW + 1 To lastRow1          ' process sheet1 against sheet2
    If ws1.Cells(rowy, 1) <> vbNullString Then
        iCnt = iCnt + 1
        Set rFnd = r2ndSheet.Find(What:=ws1.Cells(rowy, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, SearchDirection:=xlNext, MatchCase:=False)
        aStr(iCnt) = ws1.Cells(rowy, 1)
        aNdx(iCnt, 1) = rowy
        If rFnd Is Nothing Then         ' not found matching string
            aNdx(iCnt, 2) = 0
        Else                            ' match found
            aNdx(iCnt, 2) = rFnd.Row
        End If
    End If
Next rowy         ' on sheet1

For rowy = HDRROW + 1 To lastRow2            ' process sheet2 against sheet1: find nonmatching values
    If ws2.Cells(rowy, 1) <> vbNullString Then
        Set rFnd = r1stSheet.Find(What:=ws2.Cells(rowy, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, SearchDirection:=xlNext, MatchCase:=False)
        If rFnd Is Nothing Then         ' not found matching string
            iCnt = iCnt + 1
            aStr(iCnt) = ws2.Cells(rowy, 1)
            aNdx(iCnt, 1) = 0
            aNdx(iCnt, 2) = rowy
        End If
    End If
Next rowy         ' on sheet2
rFnd = Nothing

For i = 1 To iCnt
    ws3.Cells(i + HDRROW, 1) = aStr(i)   ' strings
Next i

'Find how many columns there are in sheet1 based on data in row 1
numCols = ws1.Cells(HDRROW + 1, Columns.Count).End(xlToLeft).Column
For coli = 2 To numCols
    ws3.Cells(HDRROW, Coli3) = "sheet1"   ' copy sheet 1 to the right spot of sheet 3
    ws3.Cells(HDRROW, Coli3 + 1) = "sheet2"   'copy sheet 2 to the right spot of sheet 3
    ws3.Cells(HDRROW, Coli3 + 2) = "Difference"

    For i = 1 To iCnt
        If aNdx(i, 1) = 0 Then
            ws3.Cells(i + HDRROW, Coli3) = 0
        Else
            ws3.Cells(i + HDRROW, Coli3) = ws1.Cells(aNdx(i, 1), coli).Value      ' val1
        End If

        If aNdx(i, 2) = 0 Then
            ws3.Cells(i + HDRROW, Coli3 + 1) = 0
        Else
            ws3.Cells(i + HDRROW, Coli3 + 1) = ws2.Cells(aNdx(i, 2), coli).Value  ' val2
        End If
        ws3.Cells(i + HDRROW, Coli3 + 2) = ws3.Cells(i + HDRROW, Coli3) - ws3.Cells(i + HDRROW, Coli3 + 1)        ' diff
    Next i

' finished with data, format columns
    Range(ws3.Cells(HDRROW + 1, Coli3), ws3.Cells(iCnt + HDRROW, Coli3 + 2)).NumberFormat = "#.##0"

    'Since we are placing 3 cols at a time in sheet 3 we increment differently
    Coli3 = Coli3 + 3 '1 becomes 4, 4 becomes 7, 7 becomes 10 and so on

Next coli 'move to next column on ws1, ws2

End Sub