|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub CopyMatchedColumnsByHeader()
Dim ws1 As Worksheet, ws2 As Worksheet ' 总表中的表1和表2
Dim externalWb As Workbook ' 外部目标工作簿
Dim targetWs As Worksheet ' 外部工作簿中的目标工作表
Dim lastRow1 As Long, lastRowExternal As Long, lastRow2 As Long
Dim lastCol2 As Long ' 表2的最后一列（用于获取表头范围）
Dim i As Long, j As Long, k As Long, extIndex As Long
Dim baseName As String, fullWbName As String ' 文件名（无扩展名/完整名）
Dim targetValue As String ' 表1B列的匹配值
Dim folderPath As String ' 总表所在路径
Dim copyCount As Long ' 复制行数计数
Dim headerMatch As Boolean ' 标记是否找到表头匹配的列
' 常见Excel扩展名（按优先级排序）
Dim extensions As Variant: extensions = Array(".xlsx", ".xlsm", ".xls")
' ----------------------需确认的参数----------------------
Set ws1 = ThisWorkbook.Worksheets("表1") ' 表1名称（可修改）
Set ws2 = ThisWorkbook.Worksheets("表2") ' 表2名称（可修改）
Dim targetSheetName As String: targetSheetName = "" ' 外部表名（空则默认第一个表）
Dim externalMatchCol As String: externalMatchCol = "B" ' 外部表中用于匹配的列（如B列）
' --------------------------------------------------------
' 初始化路径和表2基础信息
folderPath = ThisWorkbook.Path & "\"
lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row ' 表1最后一行
lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1 ' 表2开始粘贴的行
lastCol2 = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column ' 表2最后一列（表头范围）
' 遍历表1的每一行（从第2行开始）
For i = 2 To lastRow1
baseName = ws1.Cells(i, "A").Value ' 表1A列的文件名（无扩展名）
targetValue = ws1.Cells(i, "B").Value ' 表1B列的匹配值
fullWbName = "" ' 重置完整文件名
copyCount = 0 ' 重置复制计数
' 跳过空文件名
If baseName = "" Then
MsgBox "表1行" & i & "的文件名为空，跳过", vbExclamation
GoTo NextRow
End If
' 自动匹配扩展名
For extIndex = LBound(extensions) To UBound(extensions)
If Dir(folderPath & baseName & extensions(extIndex)) <> "" Then
fullWbName = baseName & extensions(extIndex)
Exit For
End If
Next extIndex
' 未找到文件
If fullWbName = "" Then
MsgBox "未找到文件：" & baseName & "（格式：.xlsx/.xlsm/.xls），跳过行" & i, vbExclamation
GoTo NextRow
End If
' 打开外部工作簿
On Error Resume Next
Set externalWb = Workbooks.Open(folderPath & fullWbName, ReadOnly:=True)
On Error GoTo 0
If externalWb Is Nothing Then
MsgBox "文件 " & fullWbName & " 无法打开，跳过行" & i, vbExclamation
GoTo NextRow
End If
' 指定外部工作表
If targetSheetName = "" Then
Set targetWs = externalWb.Worksheets(1)
Else
On Error Resume Next
Set targetWs = externalWb.Worksheets(targetSheetName)
On Error GoTo 0
If targetWs Is Nothing Then
MsgBox fullWbName & "中无表" & targetSheetName & "，跳过行" & i, vbExclamation
externalWb.Close False
GoTo NextRow
End If
End If
' 查找外部表中匹配B列值的行，并按表2表头复制对应列
lastRowExternal = targetWs.Cells(targetWs.Rows.Count, externalMatchCol).End(xlUp).Row
For j = 2 To lastRowExternal ' 从第2行开始（跳过外部表表头）
' 匹配外部表的指定列（如B列）与表1B列的值
If targetWs.Cells(j, externalMatchCol).Value = targetValue Then
headerMatch = False ' 重置表头匹配标记
' 遍历表2的表头列，复制匹配的内容
For k = 1 To lastCol2
' 在外部表的表头行（第1行）查找与表2表头相同的列
Dim externalCol As Long
On Error Resume Next
externalCol = targetWs.Rows(1).Find( _
What:=ws2.Cells(1, k).Value, _
LookIn:=xlValues, _
LookAt:=xlWhole).Column ' 精确匹配列名
On Error GoTo 0
' 若找到匹配列，复制数据到表2对应列
If externalCol > 0 Then
ws2.Cells(lastRow2, k).Value = targetWs.Cells(j, externalCol).Value
headerMatch = True ' 标记有匹配列
End If
Next k
' 若有至少一个列匹配，记录行数并移动到表2下一行
If headerMatch Then
lastRow2 = lastRow2 + 1
copyCount = copyCount + 1
End If
End If
Next j
' 关闭外部工作簿
externalWb.Close SaveChanges:=False
Set externalWb = Nothing: Set targetWs = Nothing
NextRow:
Next i
MsgBox "所有操作完成！", vbInformation
End Sub
|
|
楼主: olin12345
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2025-11-1 13:12
