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

Question

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

表 1 表 2

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

结束子

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