是否有一种有效的方法可以通过单元格的匹配将数据从一张图纸更新到另一张图纸

Question

我有一张工作表，它有一个主选项卡和一个数据选项卡。我每天通过从报告门户自动获得的每日报告中复制来更新数据选项卡。我将这些数据转储到数据选项卡中，并编写了一些代码来更新主选项卡中的一些列。代码与C列中的贷款编号匹配，如果找到匹配，它将执行复制和粘贴。代码运行得很好，但速度很慢，因为我已经添加了其他要复制的列。我请专家们审查我的代码，也许可以向我展示一种更有效的代码编写方法，这样它可以更快地运行。它正在搜索的数据只有几百行，我认为这不会花太长时间。这是我的代码：

Sub Update_Data()
ActiveSheet.Unprotect Password:="Mortgage1"
Application.ScreenUpdating = False
Dim stNow As Date
Dim sourceRng As Range
Dim destRng As Range
stNow = Now
lrowloans = Worksheets("Main").Range("A6").End(xlDown).Row
lrowdata = Worksheets("Data").Range("C11").End(xlDown).Row
Set sourceRng = Worksheets("Main").Range("A6:A" & lrowloans)
Set destRng = Worksheets("Data").Range("C11:C" & lrowdata)
Dim match As Boolean
For Each sRng In sourceRng
If sRng.Value <> "" Then
With destRng
Set dRng = .Find(What:=sRng.Value, After:=Worksheets("Data").Range("C11"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not dRng Is Nothing Then
Set pasteRng = Worksheets("Main").Range("E" & sRng.Row)
Set copyRng = Worksheets("Data").Range("G" & dRng.Row & ":H" & dRng.Row)
copyRng.Copy pasteRng
Set pasteRng = Worksheets("Main").Range("B" & sRng.Row)
Set copyRng = Worksheets("Data").Range("D" & dRng.Row & ":E" & dRng.Row)
copyRng.Copy pasteRng
Set pasteRng = Worksheets("Main").Range("D" & sRng.Row)
Set copyRng = Worksheets("Data").Range("U" & dRng.Row & ":U" & dRng.Row)
copyRng.Copy pasteRng
Set pasteRng = Worksheets("Main").Range("M" & sRng.Row)
Set copyRng = Worksheets("Data").Range("Q" & dRng.Row & ":Q" & dRng.Row)
copyRng.Copy pasteRng
Set pasteRng = Worksheets("Main").Range("K" & sRng.Row)
Set copyRng = Worksheets("Data").Range("AP" & dRng.Row & ":AP" & dRng.Row)
copyRng.Copy pasteRng
Set pasteRng = Worksheets("Main").Range("N" & sRng.Row)
Set copyRng = Worksheets("Data").Range("AW" & dRng.Row & ":AW" & dRng.Row)
copyRng.Copy pasteRng
End If
End With
End If
Next
Application.ScreenUpdating = True
ActiveSheet.Protect Password:="Mortgage1"
End Sub

Answer 1

这将以与您的计算机一样快的速度运行。任何差异都是通过减少阅读次数来实现的。我没有在您的代码中发现任何重要的延迟源，例如可避免的循环。

Option Explicit
' the assigned numbers are Excel's column numbers
' Test: Debug.Print Columns(NmcName).Address(0,0)
Enum Ndc                ' "Data" columns enumeration
' 132 - 08 Dec 2020
NdcName = 4         ' 4 = column D
NdcProc             ' "Processor"
NdcPurp = 7         ' "Purpose"
NdcProd             ' "Product type"
NdcLockX = 17       ' "Lock Expiry"
NdcLoan = 21        ' "Loan amount"
NdcCD = 42          ' "CD issued"
NdcClose = 49       ' "Closing date"
End Enum
Enum Nmc                ' "Main" columns
' 132 - 08 Dec 2020
NmcName = 2         ' 2 = column B
NmcProc             ' "Processor"
NmcLoan             ' "Loan amount"
NmcPurp             ' "Purpose"
NmcProd             ' "Product type"
NmcCD = 11          ' "CD issued"
NmcLockX = 13       ' "Lock Expiry"
NmcClose            ' "Closing date"
End Enum

Sub Update_Data()
' 132 - 08 Dec 2020

Const pWord         As String = "Mortgage1"

Dim WsMain          As Worksheet
Dim WsData          As Worksheet
Dim sourceRng       As Range
Dim destRng         As Range
Dim sCell           As Range                    ' loop object
Dim Fnd             As Range                    ' cell found by Find
Dim SrcArr          As Variant                  ' data from Fnd.Row
Dim SrcClm          As Variant                  ' array of source columns
Dim DstClm          As Variant                  ' array of destination columns
Dim C               As Long                     ' loop counter: column

Set WsMain = Worksheets("Main")
Set WsData = Worksheets("Data")

With WsMain
.Unprotect Password:=pWord            ' presuming WsMain is your AciveSheet
Set sourceRng = .Range(.Cells(6, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
With WsData
Set destRng = .Range(.Cells(11, "C"), .Cells(.Rows.Count, "C").End(xlUp))
End With

' data will be copied from SrcClm to DstClm, like NdcPurp to NmcPurp
' sequence is immaterial but position must match
' number of columns in both arrays must be identical
' effect modifications in the Enum
SrcClm = Array(NdcPurp, NdcProd, NdcName, NdcProc, NdcLoan, NdcLockX, NdcCD, NdcClose)
DstClm = Array(NmcPurp, NmcProd, NmcName, NmcProc, NmcLoan, NmcLockX, NmcCD, NmcClose)

Application.ScreenUpdating = False
For Each sCell In sourceRng
If sCell.Value <> "" Then
With destRng
Set Fnd = .Find(What:=sCell.Value, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not Fnd Is Nothing Then
SrcArr = .Range(.Cells(Fnd.Row, 1), .Cells(Fnd.Row, NdcClose)).Value
For C = LBound(SrcClm) To UBound(SrcClm)
WsMain.Cells(sCell.Row, DstClm(C)).Value = SrcArr(1, SrcClm(C))
Next C
End If
End With
End If
Next sCell

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
WsMain.Protect Password:=pWord
End Sub

该代码的语法已经过测试，但由于缺乏数据，还没有测试其功能。特别是枚举Ndc和NmcrcClm以及DstClm的协调可能会将一些值写入错误的列。以下是解决问题的方法。寻找这两个数组。

SrcClm = Array(NdcPurp, NdcProd, NdcName, NdcProc, NdcLoan, NdcLockX, NdcCD, NdcClose)
DstClm = Array(NmcPurp, NmcProd, NmcName, NmcProc, NmcLoan, NmcLockX, NmcCD, NmcClose)

SrcClm列出源工作表中所有使用的列。DstClm列出了目标工作表中所有使用的列。您可以添加、删除或更改。顺序无关紧要。但对于每个源单元格，都必须有一个目标单元格。因此，两个数组中的列数必须始终相同。

数组指定列。代码将找到这些行。Source行是在循环中一个接一个地确定的。Destination行为Fnd.Row。现在，代码通过这两个数组工作。它从SrcClm中获取第一列，在提供的行的帮助下找到单元格，并将其粘贴到Fnd.row行中DstClm数组的第一列。

示例：-第一个SrcClm是NdcG，它在枚举中的值为7(G列(。第一个DstClm是NmcE，它在枚举中的值为5(E列(。现在，假设不是从G列读取，而是从H列读取。因此，从枚举开始。将指定的值从7更改为8。请注意，此更改还会自动更改NdcH的值。这是因为NdcH没有赋值给它，VBA理解它的意思是"；下一个数字"；。因此，当您将NdcG更改为时，NdcH将变为9，您可能也必须更改它。

更改NdcG的值后，代码将从H列读取，正如您所希望的，但枚举的名称是错误的。如果我们为枚举提供描述性名称，如NdcName、NdcDob和NdcContractID，这个问题就不会存在。但现在的情况是，必须将NdcG更改为NdcH，并且在将现有的恩德赫改为恩德希之前，您不能这样做。

无论如何，不要更改枚举中的名称。相反，请使用编辑>替换，并将所有NdcH的出现替换为NdcI，然后将所有Ndc G的出现替换成NdcH。所有这些听起来都很复杂，事实就是如此。你需要全神贯注，避免犯错误。

当然，通过这种方式，您可以更改系统中的任何源列或目标列。这并不难，只要完成一次就可以很快完成。