由于传输大量命名范围而导致过程过大错误

时间：2019-01-07 14:27:54

标签： excel vba

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

因此，我在VBA（Dim xyz_Source As Long）中为源工作簿的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

2 个答案:

答案 0 :(得分：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！

答案 1 :(得分：-1)

我的评论示例（未经测试）

dim colname as variant, colnum as variant, i as long
colname = array("colA","colB","colC")
redim colnum(3)
for i = lbound(colname) to ubound(colname) step 1
    on error goto moo
    colnum(i) = Rows(11).Find(What:=colname(i), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
next i
for i = lbound(colnum) to ubound(colnum) step 1
    if colnum(i) > 0 then
        'use the data with cells(row,col)
    end if
next i
'on error
moo:
    colnum(i) = 0

Edit1 ：将添加一些利用率信息...

如果有所需的输出，请在定义列标题数组时使用该输出，这样当您遍历该列（第二个循环）时，可以执行以下操作：

destination.cells(lastrow+1,i).value = source.cells(31,colnum(i)).value

将value = value与复制/粘贴相对应也有助于提高速度。

编辑2：

如果有帮助，将尝试使用您的代码并更新一些内容

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.Match("Unique Identifier", Target.Range("9:9"), 0) - 1 'added -1 so you don't have to put it in other places
'array for column names
colname_Target = Range(Cells(9, 1), Cells(9, Unique_ID_Target)).Value2

'sets each array equivalent size to colname...   
ReDim colnum_Target(Unique_ID_Target)
ReDim colnum_Source(Unique_ID_Target)

'this loop populates the array colnum_target, using the values of colname_target    
For i_Target = LBound(colname_Target) To UBound(colname_Target) Step 1
    colnum_Target(i_Target) = Rows(9).Find(What:=colname_Target(i_Target), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
Next i_Target

'this loop populates the array colnum_source, using the values of colname_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

在检查代码后要说的一件事...尝试使用Dest或Target以外的其他东西，因为Target是在VBA中定义的，并且经常用于Change_Events。我认为您正在使用诸如Target = Sheets（“ Destination”）和Source = Sheets（“ Source”）之类的变量？至少这是我的推断。我对使用Target的评论基于对VBA的“ Target”的使用，对于至今为止没有捕获工作表/书籍的Source引用感到遗憾。

我会说，我很困惑为什么您要为colname / colnum添加第二个数组。拟议的目的是使用列的目标顺序，以创建与原始文档中出现的标题名称相同的列数组，以防它们的顺序不同。这样，您就可以在目标工作表中从头到尾循环（第1列到最后一列），并从源中输入数据，例如：

dest.cells(lastrowdest+1,i).value = source.cells(r,colnum(i)).value
i = i+1

拥有数组后，您可以利用数组数据，以便使用（使用2个数组，尽管仅对源数据使用1个数组即可）：

For r = 11 to lrs 'lrs is last row source, starting on 11, as it looks like your headers are in 10
    lrd = Dest.Cells(Dest.Rows.Count,1).End(xlup).row
    Dest.Cells(lrd+1,colnum_target(j)).value = Source.Cells(r,colnum_source(j))
    j = j+1
Next r

Edit3：

将尝试使用您的数据将我的想法简化为一小段代码（但由于命名约定，将Dest用于目标，而不是Target）：

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 = .range(.cells(11,1),.cells(11,lcd)).value
end with
with sheets("source")
    redim srccolnum(1,lcd)
    for i = 1 to lcd 
        srccolnum(1,i) = .rows(9).Find(What:=destcolname(1,i), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
    next i
    lrs = .cells(.rows.count,1).end(xlup).row
    for r = 10 to lrs
        lrd = sheets("destination").cells(sheets("destination").rows.count,1).end(xlup).row
        for c = 1 to lcd
            sheets("destination").cells(lrd+1,c).value = .cells(r,srccolnum(1,c)).value
        next c
    next r
end with

类似的东西应该起作用？没有测试，只是从头上做了

相关问题
最新问题