当我运行此代码时，我的笔记本电脑冻结并且不执行任何任务，我该如何解决这个问题?

Question

我有一个存档数据的 Excel 工作簿。我从主工作表中获取数据并将它们存档在不同的工作表中。

这是我为此执行的代码，但是当我运行它时，它会冻结我的笔记本电脑并且不执行任何操作：

Sub trasnfer()
Dim i  As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim SSL As String
Dim Baureihe As String
Dim Produktionsjahr As String
Dim Garantiejahr As String
Dim RateEA1 As String
Dim RateEa2 As String
Application.screenupdating = false
lastrow1 = Sheets("Transponieren").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
SSL = Sheets("Transponieren").Cells(i, "A").Value
Baureihe = Sheets("Transponieren").Cells(i, "B").Value
Produktionsjahr = Sheets("Transponieren").Cells(i, "C").Value
Garantiejahr = Sheets("Transponieren").Cells(i, "D").Value
RateEA1 = Sheets("Transponieren").Cells(i, "E").Value
Sheets("Absatzmenge").Activate
lastrow2 = Sheets("Absatzmenge").Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To lastrow2
If Sheets("Absatzmenge").Cells(j, "A").Value = Baureihe Then
If Sheets("Absatzmenge").Cells(j, "B").Value = Produktionsjahr Then
'If Sheets("Absatzmange").Cells(j, "C").Value = Produktionsjahr Then
'If Sheets("Absatzmenge").Cells(j, "D").Value = Garantiejahr Then
'If Sheets ("Absatzmenge").Cells(j, "E").Value = RateEA1 then
Sheets("Transponieren").Activate
Sheets("Transponieren").Range(Cells(i, "A").Cells(i, "E")).Copy
Sheets("Absatzmenge").Activate
Sheets("Absatzmenge").Range(Cells(j, "E").Cells(j, "H")).Select
ActiveSheet.Paste
End If
End If
Next j
Application.CutCopyMode = False
Next i
Application.screenupdating = True
Sheets("Transponieren").Activate
Sheets("Transponieren").Range("A1").Select
End Sub

我尝试了功能强大的电脑，但它做同样的事情。谢谢。

Answer 1

我做了一些效率改进(请参阅评论以获取其中一些的解释(。最大的改进将来自 避免.Select和停用ScreenUpdating.在第二个For循环中，您还应该考虑添加一个Exit For，具体取决于每个数据点要查找的匹配项数。你也不需要为每i寻找lastrow2，一次就足够了。

Sub trasnfer()
Application.ScreenUpdating = False
Dim i  As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim SSL As String
Dim Baureihe As String
Dim Produktionsjahr As String
Dim Garantiejahr As String
Dim RateEA1 As String
Dim RateEa2 As String

lastrow1 = Sheets("Transponieren").Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = Sheets("Absatzmenge").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
SSL = Sheets("Transponieren").Cells(i, "A").Value
Baureihe = Sheets("Transponieren").Cells(i, "B").Value
Produktionsjahr = Sheets("Transponieren").Cells(i, "C").Value
Garantiejahr = Sheets("Transponieren").Cells(i, "D").Value
RateEA1 = Sheets("Transponieren").Cells(i, "E").Value
For j = 2 To lastrow2
If Sheets("Absatzmenge").Cells(j, "A").Value = Baureihe And _
Sheets("Absatzmenge").Cells(j, "B").Value = Produktionsjahr Then
'If Sheets("Absatzmange").Cells(j, "C").Value = Produktionsjahr Then
'If Sheets("Absatzmenge").Cells(j, "D").Value = Garantiejahr Then
'If Sheets ("Absatzmenge").Cells(j, "E").Value = RateEA1 then
Sheets("Transponieren").Range("A" & i & ":E" & i).Copy _
Destination:=Sheets("Absatzmenge").Range("E" & j)
Application.CutCopyMode = False
'If you are only looking for one match per data point you should add "Exit For" here
'to continnue with the next line in the sheet "Transponieren"
End If
Next j
Next i
Sheets("Transponieren").Activate
Sheets("Transponieren").Range("A1").Select
Application.ScreenUpdating = True
End Sub

Answer 2

由于您的两个工作表在结构上似乎是表格形式的，第一行中有列，第二行以数据开头，并且您实际上是使用来自第一个表的匹配行的信息来丰富第二个表中的行，因此请考虑使用 SQL 来联接两个工作表并导出所需的列。

如果使用 Excel for Windows，则可以使用 JET/ACE SQL Engine 连接到工作簿，以跨不同的范围/工作表进行查询。

SQL (左连接以保留目标工作表的所有行并检索"扩充"列(

注意：请务必将列替换为实际的第一行标题。下面嵌入在 VBA 中。

SELECT t.ColumnA, t.ColumnB, t.ColumnC, t.ColumnD, t.ColumnE
FROM [Absatzmenge$] a
LEFT JOIN [Transponieren$] t 
ON t.[ColumnB] = a.[ColumnA] AND t.[ColumnC] = a.[ColumnB]

VBA(无循环，无数组，无复制/粘贴，无选择/激活(

Sub RunSQL()
On Error GoTo ErrHandle
Dim conn As Object, rst As Object
Dim sql as String
' INITIALIZE ADO OBJECTS
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
sql = "SELECT t.ColumnA, t.ColumnB, t.ColumnC, t.ColumnD, t.ColumnE" _
& " FROM [Absatzmenge$] a " _
& " LEFT JOIN [Transponieren$] t " _
& "   ON t.[ColumnB] = a.[ColumnA] AND t.[ColumnC] = a.[ColumnB]"
' OPEN RECORDSET
conn.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
& "Dbq=" & ThisWorkbook.FullName & ";"
rst.Open, conn
' EXPORT RESULTS STARTING IN E2 CELL
ThisWorkbook.Worksheets("Absatzmenge").Range("E2").CopyFromRecordset rst
' CLOSE AND RELEASE OBJECTS
rst.Close: conn.Close
ExitHandle:
Set rst = Nothing: Set conn = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitHandle
End Sub