When i run this code my laptop freezes and doesnt perform any task, how can i fix this?

Question

I have an Excel workbook that I Archive data. I take data from my main worksheet and Archive them in different worksheet.

This is the Code that I perform to do that but when I run it, it freezes my Laptop and doesnt perform anything :

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

I tried in much powerful pc but it does the same. Thank you.

You'll heavily benefit from reading [this](https://stackoverflow.com/q/10714251/9758194) — JvdV, Oct 07 '19 at 07:32
Depending on how much data you have, this code is very inefficient and might take a very long time to run. First of all, [avoid using select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba|) as much as possible. Secondly, add `application.screenupdating = false` to the beginning of your code, and set it back to true at the end. It'll speed up significantly if it doesn't have to show everything it does on screen. — Plutian, Oct 07 '19 at 07:34
The most effective way to speed this up will be to switch to a Variant Array approach. There are lots of examples here on SO — chris neilsen, Oct 07 '19 at 08:47

riskypenguin · Accepted Answer · 2019-10-07T08:42:45.463

0

I've made some efficiency improvements (please refer to the comments for explanations on some of them). The biggest improvements will come from avoiding .Select and deactivating ScreenUpdating. Inside the second For loop you should also consider adding an Exit For, depending on how many matches you are looking for per data point. You also don't need to look for lastrow2 for every i, once should be enough.

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

edited Oct 07 '19 at 08:42

answered Oct 07 '19 at 07:44

riskypenguin

2,139
1
10
22

I tried your Code withoot the **Exit For** and it blocked my Laptop. where should i put the **Exit for** please ? – Eidrizi Oct 07 '19 at 08:01
I put some comments into the code; before the `End If` inside the second `For` loop. Have you tried stepping through the code with `F8` and seeing which line causes the described effects? If not, you should. – riskypenguin Oct 07 '19 at 08:03
I went just like you said and it gives me the message _"There's already data here. Do you want to replace it ?_ and if i say no it gives me an error in the line **Sheet("Transponieren").Range("A" & i & ":E" & i).Copy _ .... :H" & j)** – Eidrizi Oct 07 '19 at 08:27
Run-Time error '1004': Copy method of Range class failed. – Eidrizi Oct 07 '19 at 08:41
so in General it gives me the datas i Need and i want just is that it asks me every time the question _"There's already data here. Do you want to replace it ?_ and i have to select yes so the datas gets copied on the sheet. – Eidrizi Oct 07 '19 at 08:42
I updated the answer to avoid the error you mentioned. I think you could get around the data replacement question by using `Application.DisplayAlerts = False`. Just be sure to set it back to `True` in an error handler. – riskypenguin Oct 07 '19 at 08:44
so my Laptop is frozen since 45 minutes. i guess it works but it takes Long time. anyways i have to do this process every year only 3 times so taking lit bit time wont matter but lets see how Long will take. – Eidrizi Oct 07 '19 at 09:33
How big is your dataset? 45 minutes seems extremely long. You could also replace `.Value` with `.Value2`, this should also speed it up a bit. – riskypenguin Oct 07 '19 at 09:37
40.000 columns of data. i will replace now with .Value2 and see. – Eidrizi Oct 07 '19 at 10:15

score 0 · Answer 2 · answered Oct 07 '19 at 21:21

Because your two worksheets appear to be tabular in structure with columns in first row and data starting in second and you essentially are enriching the rows in second table with information from matching rows of first table, consider SQL to join the two worksheets and export needed columns.

If using Excel for Windows you can connect to the very workbook using the JET/ACE SQL Engine to query across different range/worksheets.

SQL (left joins to keep all rows of target worksheet and retrieve "enriching" columns)

NOTE: Be sure to replace columns with actual first row headers. Below is embedded in 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 (no loops, no arrays, no copy/paste, no select/activate)

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

Curious, the set-based, non-loop solution did not work? Any errors you received? — Parfait, Oct 09 '19 at 14:34

When i run this code my laptop freezes and doesnt perform any task, how can i fix this?

2 Answers2