excel - 传输大量命名范围的过程错误太大

Question

我需要将大量数据从一个 Excel 工作簿导入另一个。我不能使用查询或任何其他数据连接。问题是，列（数量和顺序）会随着时间而变化。

Dim xyz_Source As Long因此，我在 VBA ( )中为源工作簿的 206 列定义了名称。然后我搜索这 206 列的位置（xyz_Source = Application.WorksheetFunction.Match("xyz", Source.Range, 0)并创建一个范围（Source.Range(Cells(2, xyz_Source), Cells(LastRow, xyz_Source）。

之后我对目标文件 ( Dim xyz_Target As Long & xyz_Target = Application.WorksheetFunction.Match("xyz", Target.Range, 0)) 执行相同的操作，并将其放在一起作为range.

最终，我将它们单独复制并粘贴到目标文件中（也是单独的），一次一个。

这基本上为这个简单的过程创建了一整本书的代码。Excel 通过一个“程序太大”回馈给我。

你知道缩短代码/循环/外包部分到其他模块的任何聪明方法吗？即让它更智能？

任何建议都非常感谢。提前非常感谢！

这是我的代码的示例/摘录：

Dim Column_Name_1_Source As Long
Dim Column_Name_2_Source As Long
Dim Column_Name_3_Source As Long
Dim Column_Name_4_Source As Long
Dim Column_Name_5_Source As Long
Dim Column_Name_6_Source As Long
Dim Column_Name_7_Source As Long
Dim Column_Name_8_Source As Long
Dim Column_Name_9_Source As Long
Dim Column_Name_10_Source As Long

Column_Name_1_Source = Application.WorksheetFunction.Match("Column Name 1", Source.Range("10:10"), 0)
Column_Name_2_Source = Application.WorksheetFunction.Match("Column Name 2", Source.Range("10:10"), 0)
Column_Name_3_Source = Application.WorksheetFunction.Match("Column Name 3", Source.Range("10:10"), 0)
Column_Name_4_Source = Application.WorksheetFunction.Match("Column Name 4", Source.Range("10:10"), 0)
Column_Name_5_Source = Application.WorksheetFunction.Match("Column Name 5", Source.Range("10:10"), 0)
Column_Name_6_Source = Application.WorksheetFunction.Match("Column Name 6", Source.Range("10:10"), 0)
Column_Name_7_Source = Application.WorksheetFunction.Match("Column Name 7", Source.Range("10:10"), 0)
Column_Name_8_Source = Application.WorksheetFunction.Match("Column Name 8", Source.Range("10:10"), 0)
Column_Name_9_Source = Application.WorksheetFunction.Match("Column Name 9", Source.Range("10:10"), 0)
Column_Name_10_Source = Application.WorksheetFunction.Match("Column Name 10", Source.Range("10:10"), 0)

Dim Column_Name_1_Target As Long
Dim Column_Name_2_Target As Long
Dim Column_Name_3_Target As Long
Dim Column_Name_4_Target As Long
Dim Column_Name_5_Target As Long
Dim Column_Name_6_Target As Long
Dim Column_Name_7_Target As Long
Dim Column_Name_8_Target As Long
Dim Column_Name_9_Target As Long
Dim Column_Name_10_Target As Long

Column_Name_1_Target = Application.WorksheetFunction.Match("Column Name 1", Target.Range("9:9"), 0)
Column_Name_2_Target = Application.WorksheetFunction.Match("Column Name 2", Target.Range("9:9"), 0)
Column_Name_3_Target = Application.WorksheetFunction.Match("Column Name 3", Target.Range("9:9"), 0)
Column_Name_4_Target = Application.WorksheetFunction.Match("Column Name 4", Target.Range("9:9"), 0)
Column_Name_5_Target = Application.WorksheetFunction.Match("Column Name 5", Target.Range("9:9"), 0)
Column_Name_6_Target = Application.WorksheetFunction.Match("Column Name 6", Target.Range("9:9"), 0)
Column_Name_7_Target = Application.WorksheetFunction.Match("Column Name 7", Target.Range("9:9"), 0)
Column_Name_8_Target = Application.WorksheetFunction.Match("Column Name 8", Target.Range("9:9"), 0)
Column_Name_9_Target = Application.WorksheetFunction.Match("Column Name 9", Target.Range("9:9"), 0)
Column_Name_10_Target = Application.WorksheetFunction.Match("Column Name 10", Target.Range("9:9"), 0)

‘Column_Name_1:
Source.Range(Cells(11, Column_Name_1_Source), Cells(Lastrow_Source, Column_Name_1_Source)).SpecialCells(xlCellTypeVisible).Copy
Target.Range(Cells(10, Column_Name_1_Target), Cells(Lastrow_Ziel, Column_Name_1_Target)).PasteSpecial xlPasteValues
‘Column_Name_2:
Source.Range(Cells(11, Column_Name_2_Source), Cells(Lastrow_Source, Column_Name_2_Source)).SpecialCells(xlCellTypeVisible).Copy
Target.Range(Cells(10, Column_Name_2_Target), Cells(Lastrow_Ziel, Column_Name_2_Target)).PasteSpecial xlPasteValues
‘Column_Name_3:
Source.Range(Cells(11, Column_Name_3_Source), Cells(Lastrow_Source, Column_Name_3_Source)).SpecialCells(xlCellTypeVisible).Copy
Target.Range(Cells(10, Column_Name_3_Target), Cells(Lastrow_Ziel, Column_Name_3_Target)).PasteSpecial xlPasteValues
‘Column_Name_4:
Source.Range(Cells(11, Column_Name_4_Source), Cells(Lastrow_Source, Column_Name_4_Source)).SpecialCells(xlCellTypeVisible).Copy
Target.Range(Cells(10, Column_Name_4_Target), Cells(Lastrow_Ziel, Column_Name_4_Target)).PasteSpecial xlPasteValues
‘Column_Name_5:
Source.Range(Cells(11, Column_Name_5_Source), Cells(Lastrow_Source, Column_Name_5_Source)).SpecialCells(xlCellTypeVisible).Copy
Target.Range(Cells(10, Column_Name_5_Target), Cells(Lastrow_Ziel, Column_Name_5_Target)).PasteSpecial xlPasteValues
‘Column_Name_6:
Source.Range(Cells(11, Column_Name_6_Source), Cells(Lastrow_Source, Column_Name_6_Source)).SpecialCells(xlCellTypeVisible).Copy
Target.Range(Cells(10, Column_Name_6_Target), Cells(Lastrow_Ziel, Column_Name_6_Target)).PasteSpecial xlPasteValues
‘Column_Name_7:
Source.Range(Cells(11, Column_Name_7_Source), Cells(Lastrow_Source, Column_Name_7_Source)).SpecialCells(xlCellTypeVisible).Copy
Target.Range(Cells(10, Column_Name_7_Target), Cells(Lastrow_Ziel, Column_Name_7_Target)).PasteSpecial xlPasteValues
‘Column_Name_8:
Source.Range(Cells(11, Column_Name_8_Source), Cells(Lastrow_Source, Column_Name_8_Source)).SpecialCells(xlCellTypeVisible).Copy
Target.Range(Cells(10, Column_Name_8_Target), Cells(Lastrow_Ziel, Column_Name_8_Target)).PasteSpecial xlPasteValues
‘Column_Name_9:
Source.Range(Cells(11, Column_Name_9_Source), Cells(Lastrow_Source, Column_Name_9_Source)).SpecialCells(xlCellTypeVisible).Copy
Target.Range(Cells(10, Column_Name_9_Target), Cells(Lastrow_Ziel, Column_Name_9_Target)).PasteSpecial xlPasteValues
‘Column_Name_10:
Source.Range(Cells(11, Column_Name_10_Source), Cells(Lastrow_Source, Column_Name_10_Source)).SpecialCells(xlCellTypeVisible).Copy
Target.Range(Cells(10, Column_Name_10_Target), Cells(Lastrow_Ziel, Column_Name_10_Target)).PasteSpecial xlPasteValues

带循环的新代码（仍然有错误）：

Dim colname_Target As Variant
Dim colnum_Target As Variant
Dim colnum_Source As Variant
Dim i_Target As Long
Dim Unique_ID_Target As Long

Unique_ID_Target = Application.WorksheetFunction.Match("Unique Identifier", Target.Range("9:9"), 0)
colname_Target = Application.Transpose(Application.Transpose(Target.Range(Cells(9, 1).Address, Cells(9, Unique_ID_Target - 1).Address).Value2))

ReDim colnum_Target(Unique_ID_Target)
ReDim colnum_Source(Unique_ID_Target)

For i_Target = LBound(colname_Target) To UBound(colname_Target) Step 1
    colnum_Target(i_Target) = Target.Rows(9).Find(What:=colname_Target(i_Target), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
Next i_Target

For i_Target = LBound(colname_Target) To UBound(colname_Target) Step 1
    colnum_Source(i_Target) = Source.Rows(10).Find(What:=colname_Target(i_Target), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
Next i_Target

标签： excelvba

Answer 1

在对@Cyril 的代码进行了一些更改后，这个代码可以完美运行：

Dim i As Long, destcolname As Variant, srccolnum As Variant, lrd As Long, lcd As Long, lrs As Long, r As Long, c As Long

With Sheets("destination")
    lrd = .Cells(.Rows.Count, 1).End(xlUp).Row
    lcd = .cells(11,.columns.count).end(xltoleft).column
    destcolname = Application.Transpose(.Range(.Cells(9, 1), .Cells(9, lcd)).Value)

End With
With Sheets("Source")
    ReDim srccolnum(lcd, 1)
    For i = 1 To lcd
    On Error Resume Next
        srccolnum(i, 1) = .Rows(10).Find(What:=destcolname(i, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
    Next i
End With

With Sheets("destination")
    lrs = Sheets("Source").Cells(.Rows.Count, 1).End(xlUp).Row
    For r = 11 To lrs
        lrd = Sheets("destination").Cells(.Rows.Count, 1).End(xlUp).Row
        For c = 1 To lcd
            Sheets("destination").Cells(lrd + 1, c).Value = Sheets("Source").Cells(r, srccolnum(c, 1)).Value
        Next c
    Next r
End With

再次感谢@Cyril！