使用 VBA 从两个现有工作表创建工作表

Question

我想从两个不同的工作表中复制一些列数据。 列不一样，因为此信息来自两个不同的数据库。

突出显示的列是我需要复制到新数据库中的信息：

在这个数据库中有两个绿色突出显示的列。
如果“M”列上有 id 数据，如果没有，我会从“F”列复制：

我的代码有效。 问题是从我加载大量数据的那一刻起，Excel 崩溃了。

Sub KPI()

Dim ws As Worksheet: Set ws = Sheets("Actuals")
Dim ws_omt As Worksheet: Set ws_omt = Sheets("OMT")

'declare and set your worksheet, amend as required
Dim wsResult As Worksheet: Set wsResult = Sheets("DB")
LastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
LastRow_omt = ws_omt.Cells(ws_omt.Rows.Count, "D").End(xlUp).Row
'get the last row with data on the orders column

For i = 2 To LastRow
    NextRow = wsResult.Cells(wsResult.Rows.Count, "C").End(xlUp).Row + 1
    ws.Range("C" & i & ":D" & i).Copy Destination:=wsResult.Range("B" & NextRow)
    ws.Range("L" & i & ":L" & i).Copy Destination:=wsResult.Range("D" & NextRow)
    ws.Range("F" & i & ":F" & i).Copy Destination:=wsResult.Range("H" & NextRow)
    ws.Range("N" & i & ":N" & i).Copy Destination:=wsResult.Range("E" & NextRow)
    ws.Range("O" & i & ":O" & i).Copy Destination:=wsResult.Range("F" & NextRow)
    ws.Range("X" & i & ":X" & i).Copy Destination:=wsResult.Range("G" & NextRow)
    wsResult.Range("A" & NextRow).Value = "Actuals"
    wsResult.Range("I" & NextRow).Value = "None"
Next
    
For i2 = 2 To LastRow_omt
    NextRow = wsResult.Cells(wsResult.Rows.Count, "C").End(xlUp).Row + 1
    ws_omt.Range("D" & i2 & ":D" & i2).Copy Destination:=wsResult.Range("C" & NextRow)
    ws_omt.Range("G" & i2 & ":G" & i2).Copy Destination:=wsResult.Range("G" & NextRow)
    ws_omt.Range("J" & i2 & ":K" & i2).Copy Destination:=wsResult.Range("E" & NextRow)
    
    If ws_omt.Range("M" & i2 & ":M" & i2).Value <> "" Then
        ws_omt.Range("M" & i2 & ":M" & i2).Copy Destination:=wsResult.Range("H" & NextRow)
    ElseIf ws_omt.Range("F" & i2 & ":F" & i2).Value <> "" And ws_omt.Range("M" & i2 & ":M" & i2).Value = "" Then
        ws_omt.Range("F" & i2 & ":F" & i2).Copy Destination:=wsResult.Range("H" & NextRow)
        wsResult.Range("J" & NextRow).Value = "1"
    Else
    wsResult.Range("H" & NextRow).Value = "None"
    End If
    
    ws_omt.Range("A" & i2 & ":A" & i2).Copy Destination:=wsResult.Range("I" & NextRow)
    wsResult.Range("A" & NextRow).Value = "OMT"
    wsResult.Range("D" & NextRow).Value = "None"
    wsResult.Range("B" & NextRow).Value = 1
Next
    
LastRow_db = wsResult.Cells(wsResult.Rows.Count, "C").End(xlUp).Row

For i3 = 2 To LastRow_db
    If wsResult.Range("A" & i3 & ":A" & i3).Value = "OMT" Then
        wsResult.UsedRange.RemoveDuplicates Columns:=3, Header:=xlYes
        'RemoveRups just working removing from bottom-up if conditions dont look to work
    End If
Next

End Sub

Answer 1

下面的一些建议。 您不需要循环进行大部分复制，正如 Nathan 指出的那样，您可以切换到直接分配Value ，因为这样会更快，只要您不需要复制格式。

Sub KPI()

    Const DATA_START_ROW As Long = 2 'use constants for fixed values
    
    Dim LastRow As Long, i3 As Long, rngIds As Range,
    Dim ws As Worksheet, ws_omt As Worksheet, wsResult As Worksheet
    Dim allData As Range, rw As Range, mVal, fVal, rwDest As Range

    'don't combine declarations and assignments on the same line...
    Set ws = Sheets("Actuals")
    Set ws_omt = Sheets("OMT")
    Set wsResult = Sheets("DB")

    'speed up
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual


    '----first sheet--------
    'all the input data
    LastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    Set allData = ws.Range("A" & DATA_START_ROW & ":A" & LastRow).EntireRow
    'next destination row
    Set rwDest = wsResult.Cells(wsResult.Rows.Count, "C").End(xlUp).Offset(1, 0).EntireRow
    
    'you're copying all of the data so no need to go row-by-row
    allData.Columns("C:D").Copy rwDest.Columns("B")
    allData.Columns("L").Copy rwDest.Columns("D")
    allData.Columns("F").Copy rwDest.Columns("H")
    allData.Columns("N").Copy rwDest.Columns("E")
    allData.Columns("O").Copy rwDest.Columns("F")
    allData.Columns("X").Copy rwDest.Columns("G")
    'fixed values
    rwDest.Columns("A").Resize(allData.Rows.Count).Value = "Actuals"
    rwDest.Columns("I").Resize(allData.Rows.Count).Value = "None"
    
    '----next sheet--------
    'next input data
    LastRow = ws_omt.Cells(ws_omt.Rows.Count, "D").End(xlUp).Row
    Set allData = ws_omt.Range("A" & DATA_START_ROW & ":A" & LastRow).EntireRow
    'next destination row
    Set rwDest = wsResult.Cells(wsResult.Rows.Count, "C").End(xlUp).Offset(1, 0).EntireRow
    
    'copy whole columns first
    allData.Columns("A").Copy rwDest.Columns("I")
    allData.Columns("D").Copy rwDest.Columns("C")
    allData.Columns("G").Copy rwDest.Columns("G")
    allData.Columns("J:K").Copy rwDest.Columns("E")
    'fixed values
    rwDest.Columns("A").Resize(allData.Rows.Count).Value = "OMT"
    rwDest.Columns("D").Resize(allData.Rows.Count).Value = "None"
    rwDest.Columns("B").Resize(allData.Rows.Count).Value = 1
    
    'only loop where you need to
    For Each rw In allData.Rows
        mVal = rw.Columns("M").Value
        fVal = rw.Columns("F").Value
        If Len(mVal) > 0 Then
            rw.Columns("M").Copy rwDest.Columns("H")
        ElseIf Len(fVal) > 0 And Len(mVal = 0) Then
            rw.Columns("F").Copy rwDest.Columns("H")
            rwDest.Columns("J").Value = "1"
        Else
            rwDest.Columns("H").Value = "None"
        End If
        Set rwDest = rwDest.Offset(1, 0) 'next destination row
    Next rw
 
    LastRow = wsResult.Cells(wsResult.Rows.Count, "C").End(xlUp).Row
    Set rngIds = wsResult.Range("C" & DATA_START_ROW & ":C" & LastRow)
    For i3 = LastRow To DATA_START_ROW Step -1
        If wsResult.Cells(i3, "A").Value = "OMT" Then
            If Application.CountIf(rngIds, wsResult.Cells(i3, "C").Value) > 1 Then
                wsResult.Rows(i3).Delete
            End If
        End If
    Next
    
    'reset
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub