我正在尝试编写一个代码，使用与我的主文件位于同一文件夹中的其他 Excel 文件的数据来更新我的主 Excel 文档。每个 Excel 的第一行是相同的（标题）。
每个元素（行）都有一个唯一标识符：第 1、3 和 6 列的单元格值组合。同一行的其他列是该元素的特征。我想更新我的主文档的每个元素（行）。
如果在该文件夹中另一个 Excel 文件的任何行中找到该唯一元素，我想比较每个特征的单元格值，并使用另一个文件中但不在我的主文档中的信息更新我的主文档。 （每个单元格中的信息用逗号分隔，例如，如果特征 1 = 形状，则单元格中的信息将类似于“圆形，零件中的凹痕，...，..”）
如果文件夹中任何其他文件中的一行具有主文档中尚未存在的唯一标识符，我想将该整行复制到主文档最后使用的行下方。
我的代码有什么问题，我应该如何改进？ 预先感谢
这是我目前拥有的，但是当我运行它时，什么也没有发生。 （我不懂 VBA。我尝试了多种 ChatGPT 风格的工具来尝试理解并将某些内容粘贴在一起）：
Sub UpdateMasterDocument()
Dim MasterWb As Workbook
Dim MasterWs As Worksheet
Dim OtherWb As Workbook
Dim OtherWs As Worksheet
Dim MasterRow As Long
Dim OtherRow As Long
Dim LastRow As Long
Dim FolderPath As String
Dim FileName As String
Dim MatchFound As Boolean
Dim i As Integer
Dim j As Integer
Dim MasterValue As String
Dim OtherValue As String
Dim MasterArray() As String
Dim OtherArray() As String
Set MasterWb = ThisWorkbook
Set MasterWs = ThisWorkbook.Sheets(1)
FolderPath = ThisWorkbook.Path
FileName = Dir(MyFolder & "\*.xls*")
Do While FileName <> ""
Set OtherWb = Workbooks.Open(FolderPath & FileName)
Set OtherWs = OtherWb.Sheets(1)
For MasterRow = 2 To MasterWs.Cells(Rows.Count, 1).End(xlUp).Row
MatchFound = False
For OtherRow = 2 To OtherWs.Cells(Rows.Count, 1).End(xlUp).Row
If MasterWs.Cells(MasterRow, 1).Value & MasterWs.Cells(MasterRow, 3).Value & MasterWs.Cells(MasterRow, 6).Value = OtherWs.Cells(OtherRow, 1).Value & OtherWs.Cells(OtherRow, 3).Value & OtherWs.Cells(OtherRow, 6).Value Then
MatchFound = True
For i = 1 To OtherWs.Cells(OtherRow, Columns.Count).End(xlToLeft).Column
If i <> 1 And i <> 3 And i <> 6 Then
MasterValue = MasterWs.Cells(MasterRow, i).Value
OtherValue = OtherWs.Cells(OtherRow, i).Value
MasterArray = Split(MasterValue, ", ")
OtherArray = Split(OtherValue, ", ")
For j = LBound(OtherArray) To UBound(OtherArray)
If IsInArray(OtherArray(j), MasterArray) = False Then
MasterWs.Cells(MasterRow, i).Value = MasterWs.Cells(MasterRow, i).Value & ", " & OtherArray(j)
End If
Next j
End If
Next i
Exit For
End If
Next OtherRow
If MatchFound = False Then
LastRow = MasterWs.Cells(Rows.Count, 1).End(xlUp).Row + 1
OtherWs.Rows(OtherRow).Copy Destination:=MasterWs.Rows(LastRow)
End If
Next MasterRow
OtherWb.Close SaveChanges:=False
FileName = Dir
Loop
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i) = stringToBeFound Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
由于我不懂 VBA，我试图将其简化为更小的部分。下面的代码更新了同一 ws 中行的部分单元格，但我不知道如何在上面的代码中实现它并使其运行。
Sub UpdateData()
Dim ws As Worksheet
Dim rng As Range
Dim i As Long, j As Long
Dim rowZ As Range, rowX As Range
Dim cellZ As Range, cellX As Range
Set ws = ThisWorkbook.Sheets(1)
Set rng = ws.UsedRange
For i = 1 To rng.Rows.Count
Set rowZ = rng.Rows(i)
For j = 1 To rng.Rows.Count
If i <> j Then
Set rowX = rng.Rows(j)
If rowZ.Cells(1, 1).Value = rowX.Cells(1, 1).Value Then
For Each cellZ In rowZ.Cells
Set cellX = rowX.Cells(1, cellZ.Column)
If cellZ.Value <> cellX.Value Then
cellZ.Value = cellZ.Value & ";" & cellX.Value
cellX.Value = cellZ.Value
End If
Next cellZ
End If
End If
Next j
Next i
End Sub
使用字典对象来匹配唯一标识符并扫描其他 Excel 文件一次。
Option Explicit
Sub UpdateMasterDocument()
Const SEP = ";"
Dim wbMaster As Workbook, wb As Workbook
Dim wsMaster As Worksheet, ws As Worksheet
Dim Folder As String, filename As String
Dim sMaster As String, sSrc As String, v
Dim r As Long, rMaster As Long
Dim rLastMaster As Long, rLastSrc As Long
Dim lastCol As Long
Dim i As Long, n As Long, m As Long, f As Long
Dim t0: t0 = Timer
Dim dict As Object, k, ar
Set dict = CreateObject("Scripting.Dictionary")
' master unique ids
Set wbMaster = ThisWorkbook
Set wsMaster = wbMaster.Sheets(1)
With wsMaster
rLastMaster = .Cells(.Rows.Count, "A").End(xlUp).Row
ar = .Range("A1:F1").Resize(rLastMaster)
For r = 2 To UBound(ar)
k = ar(r, 1) & SEP & ar(r, 3) & SEP & ar(r, 6)
If dict.exists(k) Then
MsgBox "Duplicate ID " & k, vbCritical, "Row " & r
Exit Sub
Else
dict.Add k, r
End If
Next
End With
' scan folder
Folder = wbMaster.Path
filename = Dir(Folder & "\*.xls*")
Application.ScreenUpdating = False
Do While filename <> ""
f = f + 1
'Debug.Print filename
'scan rows in file
Set ws = Workbooks.Open(Folder & filename).Sheets(1)
With ws
rLastSrc = .Cells(.Rows.Count, "A").End(xlUp).Row
ar = .Range("A1:F1").Resize(rLastSrc)
For r = 2 To UBound(ar)
lastCol = .Cells(r, .Columns.Count).End(xlToLeft).Column
k = ar(r, 1) & SEP & ar(r, 3) & SEP & ar(r, 6)
' exists in master ?
If dict.exists(k) Then
rMaster = dict(k)
For i = 1 To lastCol
sMaster = wsMaster.Cells(rMaster, i)
sSrc = .Cells(r, i)
For Each v In Split(sSrc, ",")
'Debug.Print "'" & sMaster & "'", "'" & Trim(v) & "'"
If InStr(1, sMaster, Trim(v), 1) = 0 Then
sMaster = sMaster & ", " & v
m = m + 1
wsMaster.Cells(rMaster, i).Interior.Color = RGB(255, 255, 127)
End If
Next
wsMaster.Cells(rMaster, i) = sMaster
Next
Else
' add new row to master
rLastMaster = rLastMaster + 1
ws.Cells(r, 1).Resize(, lastCol).Copy wsMaster.Cells(rLastMaster, 1)
n = n + 1
End If
Next
End With
filename = Dir
Loop
Application.ScreenUpdating = False
' result
MsgBox f & " files scanned in " & Folder & vbLf & _
m & " cells updated" & vbLf & _
n & " rows added", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub