Question

我正在尝试将数据从第一张传输到第二张，并将信息合并到第二张纸上。我在下面列出的代码有效，但效果似乎非常低效。我正在尝试通过VBA的能力进行改进，并希望通过这种方式缩小我的代码，使其更高效，并仍然实现相同的目标。感谢您提供的任何帮助。

Sub batchorder()
Dim Pname As String
Dim Lplace As String
Dim numsld As Long
Dim rating As Integer
Dim lastrow As Long
Dim i As Long
Dim openc As Long


lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1").Select

For i = 1 To lastrow
    If Cells(i, 1).Value <> "" Then
        'Copy name to sheet 2
        Cells(i, 1).Select
        ActiveCell.Offset(0, 1).Select
        Selection.Copy
        Sheets("Sheet2").Select
        Range("A1").Select
        'Find the next open cell to paste to
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.End(xlUp).Select
        ActiveCell.Offset(1, 0).Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
            'Copy place to sheet 2
             ActiveCell.Offset(1, 0).Select
             Selection.Copy
             Sheets("Sheet2").Select
             Range("B1").Select
            'Find the next open cell to paste to
            Selection.End(xlDown).Select
            Selection.End(xlDown).Select
            Selection.End(xlUp).Select
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Paste
            Sheets("Sheet1").Select
                'Copy sold to sheet 2
                 ActiveCell.Offset(1, 0).Select
                 Selection.Copy
                 Sheets("Sheet2").Select
                 Range("C1").Select
                'Find the next open cell to paste to
                Selection.End(xlDown).Select
                Selection.End(xlDown).Select
                Selection.End(xlUp).Select
                ActiveCell.Offset(1, 0).Select
                ActiveSheet.Paste
                Sheets("Sheet1").Select
                    'Copy rating to sheet 2
                     ActiveCell.Offset(1, 0).Select
                     Selection.Copy
                     Sheets("Sheet2").Select
                     Range("D1").Select
                    'Find the next open cell to paste to
                    Selection.End(xlDown).Select
                    Selection.End(xlDown).Select
                    Selection.End(xlUp).Select
                    ActiveCell.Offset(1, 0).Select
                    ActiveSheet.Paste
                    Sheets("Sheet1").Select
    Sheets("Sheet1").Select
    i = i + 3
    Else
    End If
Next i

End Sub

Answer 1

Sub batchorder()


    Dim Row As Long
    Dim i As Long

    ' These two lines speed up evrything ENORMOUSLY. 
    ' But you need the lines at the end too
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Row = Sheet2.UsedRange.Rows.Count  ' Row is nr of last row in sheet

    While Application.CountA(Sheet2.Rows(Row)) = 0 And Row > 1
        Row = Row - 1 ' skip empty rows at the end if present
    Wend

    For i = 1 To Sheet1.UsedRange.Rows.Count
        If Sheet1.Cells(i, 1).Value <> "" Then
            Sheet2.Cells(Row, 1).FormulaLocal = Sheet1.Cells(i, 2).FormulaLocal
            Sheet2.Cells(Row, 2).FormulaLocal = Sheet1.Cells(i + 1, 2).FormulaLocal
            Sheet2.Cells(Row, 3).FormulaLocal = Sheet1.Cells(i + 2, 2).FormulaLocal
            Sheet2.Cells(Row, 4).FormulaLocal = Sheet1.Cells(i + 3, 2).FormulaLocal
            i = i + 3
            Row = Row + 1
        End If
    Next

    ' Restore Excel to human state.
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Answer 2

你基本上不应该使用select语句，它会让一切变得非常混乱。这是我的基本组合器。刚添加了If语句来检查单元格和本例中的行是否为空。

这应该有用，但更重要的是要尝试了解它的作用。我给了它一些评论。

Sub batchorder()
Dim ws1 As Worksheet
Dim ws2 As Worksheet

' Just habits, but doing this here means that I won't have to write anything else than ws1 and ws2 in the future
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

Dim lastrowWs1 As Long
Dim j As Long
' first row after ws2 headers
j = 2


' With statement to make the code nicer also ".something" now means ws1.something
With ws1

' Bob Ulmas method -- just a personal preference to find the last row.
lastrowWs1 = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

For i = 1 To lastrowWs1
    ' Check if the cell is not empty
    If Not .Cells(i, 1) = vbNullString Then
        'Basically range.value = other_range.value
        ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 4)).Value = WorksheetFunction.Transpose(.Range(.Cells(i, 2), .Cells(i + 3, 2)).Value)
        ' step 3 forward as the amount of rows per record was 4
        i = i + 3
        ' go to next row for worksheet 2
        j = j + 1
    End If
Next i

End With


End Sub

如何简化使用活动单元格/复制/粘贴在工作表之间传输数据？

2 个答案: