Vba 如何从两个不同的工作表中搜索数据并将其复制到第三个工作表中？

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

---

请帮忙。

试试看。该策略是收集缓冲区中所有唯一的字符串值，并将它们的行值存储在索引缓冲区中（假设一个字符串在一张工作表上只出现一次）。然后从索引缓冲区中获取所有行值，并将该行中的值复制到ws3。 注意：我将loop和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

Sub宏5（）
'
'宏5宏
'
'
将ws1设置为工作表
将ws2设置为工作表
将ws3设置为工作表
长得一样
3倍长
昏昏欲睡
暗淡的numCols与长
将lastRow1标注为“实际数据列中sheet1上的最后一行”
将lastRow2标注为“实际数据列中sheet2上的最后一行”
图纸1上的尺寸r1stSheet As Range“字符串列范围”
尺寸R2ND图纸作为图纸2上的“字符串-列范围”
尺寸rFnd作为搜索辅助范围
Const MAXROW=100'最大行数
Const HDRROW=标题所在的6'行
Dim aStr（1到MAXROW）作为列1中的字符串
尺寸aNdx（1到最大行，1到2）与“col1:图纸1或0上的行，col2:图纸2或0上的行”一样长
作为aNdx中最后一个有效条目的Dim iCnt
'Dim dict As Scripting.Dictionary
startRow=6'假设数据从这里开始
Coli3=2'在ws3上启动列
设置ws1=ThisWorkbook.Worksheets（“sheet1”）
设置ws2=ThisWorkbook.Worksheets（“sheet2”）
设置ws3=ThisWorkbook.Worksheets（“sheet3”）
'Application.ScreenUpdate=False
ws3.Cells.Clear
'为sheet1和sheet2上的所有字符串创建唯一列表
lastRow1=ws1.Cells（ws1.Rows.Count，1）.End（xlUp）.Row
lastRow2=ws2.Cells（ws2.Rows.Count，1）.End（xlUp）.Row
设置r1stSheet=Range（ws1.Cells（6,1），ws1.Cells（lastRow1,1））
设置r2ndSheet=Range（ws2.Cells（6,1），ws2.Cells（lastRow2,1））
iCnt=0
对于rowy=HDRROW+1到lastRow1'的流程表1与表2
如果ws1.Cells（rowy，1）为vbNullString，则
iCnt=iCnt+1
设置rFnd=r2ndSheet.Find（What:=ws1.Cells（rowy，1），LookIn:=xlValues，LookAt:=xlother，SearchOrder:=xlRows，SearchDirection:=xlNext，MatchCase:=False）
aStr（iCnt）=ws1.单元格（rowy，1）
aNdx（iCnt，1）=rowy
如果rFnd为Nothing，则“未找到匹配字符串”
aNdx（iCnt，2）=0
找到其他人的匹配项
aNdx（iCnt，2）=rFnd.行
如果结束
如果结束
第1页上的下一个rowy
对于rowy=HDRROW+1到lastRow2'根据sheet1处理sheet2：查找不匹配的值
如果ws2.Cells（rowy，1）为vbNullString，则
设置rFnd=r1stSheet.Find（What:=ws2.Cells（rowy，1），LookIn:=xlValues，LookAt:=xlother，SearchOrder:=xlRows，SearchDirection:=xlNext，MatchCase:=False）
如果rFnd为Nothing，则“未找到匹配字符串”
iCnt=iCnt+1
aStr（iCnt）=ws2.单元格（rowy，1）
aNdx（iCnt，1）=0
aNdx（iCnt，2）=rowy
如果结束
如果结束
第2张上的下一个rowy
rFnd=无
对于i=1到iCnt
ws3.Cells（i+HDRROW，1）=aStr（i）'字符串
接下来我
'根据第1行中的数据查找sheet1中有多少列
numCols=ws1.Cells（HDRROW+1，Columns.Count）.End（xlToLeft）.Column
对于coli=2到numCols
ws3.单元格（HDRROW，Coli3）=“sheet1”将第1页复制到第3页的右侧位置
ws3.单元格（HDRROW，Coli3+1）=“sheet2”将第2页复制到第3页的右侧位置
ws3.单元格（HDRROW，Coli3+2）=“差异”
对于i=1到iCnt
如果aNdx（i，1）=0，则
ws3.单元（i+HDRROW，Coli3）=0
其他的
ws3.Cells（i+HDRROW，Coli3）=ws1.Cells（aNdx（i，1），coli）.值'val1
如果结束
如果aNdx（i，2）=0，则
ws3.单元格（i+HDRROW，Coli3+1）=0
其他的
ws3.Cells（i+HDRROW，Coli3+1）=ws2.Cells（aNdx（i，2），coli）.值'val2
如果结束
ws3.Cells（i+HDRROW，Coli3+2）=ws3.Cells（i+HDRROW，Coli3）-ws3.Cells（i+HDRROW，Coli3+1）的差异
接下来我
'已完成数据，格式化列
范围（ws3.Cells（HDRROW+1，Coli3），ws3.Cells（iCnt+HDRROW，Coli3+2））.NumberFormat=“#.##0”
'由于我们在表3中一次放置3列，因此增量不同
Coli3=Coli3+3'1变为4，4变为7，7变为10，依此类推
“下一列”移动到ws1、ws2上的下一列
端接头

我收到下标超出范围错误。有什么方法可以把输入文件发送给你吗？我在这一行得到：aStr（iCnt）=ws1。Cells（rowy，1）你能有100多行吗？您可能需要调整MAXROW常量。或者在iCnt=iCnt+1之后进行如下检查：如果iCnt>MAXROW，则：msgbox“Adjust MAXROW contant！”：exit sub:endif在移动时确定每个列的最后一行，实际确定两张图纸上的最后一行，因此，您可以使用较大的数据运行，并在运行过程中处理丢失的数据。您关心的是确保表1或表2中是否缺少值，以便继续进行比较？这是可以做到的！st每次移动到处理列时，我们需要找到表1的最大行数和表2的最大行数（也许每次它们的长度都不相同），然后我们使用较大的#作为循环计数器。我们在其中放置一个if语句，如果其中一个是空的，只需将其设为0，在这种情况下，差值将始终是非空单元格（+或-），或者我们c