Reformulate the code so it doesn't crash

PIsabel

PIsabel

Board Regular
Joined
Feb 4, 2014
Messages
122
Office Version
  1. 365
Platform
  1. Windows
How can I speed up this code?
Data is entered in column A between lines 3:1001.
Between the DT:LU columns I have sets of 7 columns that I use to process and divide the data entered in column A (DT3:DZ1001 | EA3:EG1001 and so on until LO3:LU1001)
If any row in column A has no data, all columns in that row are "empty".
If any row in column A has data, I always have at least one set of columns with data, but the number of sets with data always depends on the data entered (I can have a set or 10 or 20 or all sets of columns, from that row with data )
I can have rows with data interspersed with empty rows

The code I have does all this but it takes a long time and sometimes crashes.

Basically I have to simplify the code.

The code has to copy the lines with data, paste them into the "Components" sheet in columns A:G without blank lines because I use these lines to import data into another program and if there are empty lines it gives an error


VBA Code: 
    Sheets("Componentes").Range("A2:G1000").Value = Range("DT3:DZ1001").Value
    Sheets("Componentes").Range("A1001:G1999").Value = Range("EA3:EG1001").Value
    Sheets("Componentes").Range("A2000:G2998").Value = Range("EH3:EN1001").Value
    Sheets("Componentes").Range("A2999:G3997").Value = Range("EO3:EU1001").Value
    Sheets("Componentes").Range("A3998:G4996").Value = Range("EV3:FB1001").Value
    Sheets("Componentes").Range("A4997:G5995").Value = Range("FC3:FI1001").Value
    Sheets("Componentes").Range("A5996:G6994").Value = Range("FJ3:FP1001").Value
    Sheets("Componentes").Range("A6995:G7993").Value = Range("FQ3:FW1001").Value
    Sheets("Componentes").Range("A7994:G8992").Value = Range("FX3:GD1001").Value
    Sheets("Componentes").Range("A8993:G9991").Value = Range("GE3:GK1001").Value
    Sheets("Componentes").Range("A9992:G10990").Value = Range("GL3:GR1001").Value
    Sheets("Componentes").Range("A10991:G11989").Value = Range("GS3:GY1001").Value
    Sheets("Componentes").Range("A11990:G12988").Value = Range("GZ3:HF1001").Value
    Sheets("Componentes").Range("A12989:G13987").Value = Range("HG3:HM1001").Value
    Sheets("Componentes").Range("A13988:G14986").Value = Range("HN3:HT1001").Value
    Sheets("Componentes").Range("A14987:G15985").Value = Range("HU3:IA1001").Value
    Sheets("Componentes").Range("A15986:G16984").Value = Range("IB3:IH1001").Value
    Sheets("Componentes").Range("A16985:G17983").Value = Range("II3:IO1001").Value
    Sheets("Componentes").Range("A17984:G18982").Value = Range("IP3:IV1001").Value
    Sheets("Componentes").Range("A18983:G19981").Value = Range("IW3:JC1001").Value
    Sheets("Componentes").Range("A19982:G20980").Value = Range("JD3:JJ1001").Value
    Sheets("Componentes").Range("A20981:G21979").Value = Range("JK3:JQ1001").Value
    Sheets("Componentes").Range("A21980:G22978").Value = Range("JR3:JX1001").Value
    Sheets("Componentes").Range("A22979:G23977").Value = Range("JY3:KE1001").Value
    Sheets("Componentes").Range("A23978:G24976").Value = Range("KF3:KL1001").Value
    Sheets("Componentes").Range("A24977:G25975").Value = Range("KM3:KS1001").Value
    Sheets("Componentes").Range("A25976:G26974").Value = Range("KT3:KZ1001").Value
    Sheets("Componentes").Range("A26975:G27973").Value = Range("LA3:LG1001").Value
    Sheets("Componentes").Range("A27974:G28972").Value = Range("LH3:LN1001").Value
    Sheets("Componentes").Range("A28973:G29971").Value = Range("LO3:LU1001").Value
    'delete empty lines
    On Error Resume Next
    [A:A].AutoFilter Field:=1, Criteria1:="="
    [A2:A29971].SpecialCells(xlVisible).EntireRow.Delete
    If [A1] = "" Then [1:1].Delete
    ActiveSheet.AutoFilterMode = False
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Sort by date Sort by votes
Since you only partially show your macro, try the following:
Add at the beginning of your macro:
VBA Code: 
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual   '<- not needed if there are no formulas in your sheet
End With
and then at the end of the macro:
Code: 
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic  '<- same as above
End With
Msgbox "Done!"
 
Upvote 0
See if this makes any difference:

VBA Code: 
Sub Test()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    With Sheets("Componentes")
        .Range("A2:G1000").Value = .Range("DT3:DZ1001").Value
        .Range("A1001:G1999").Value = .Range("EA3:EG1001").Value
        .Range("A2000:G2998").Value = .Range("EH3:EN1001").Value
        .Range("A2999:G3997").Value = .Range("EO3:EU1001").Value
        .Range("A3998:G4996").Value = .Range("EV3:FB1001").Value
        .Range("A4997:G5995").Value = .Range("FC3:FI1001").Value
        .Range("A5996:G6994").Value = .Range("FJ3:FP1001").Value
        .Range("A6995:G7993").Value = .Range("FQ3:FW1001").Value
        .Range("A7994:G8992").Value = .Range("FX3:GD1001").Value
        .Range("A8993:G9991").Value = .Range("GE3:GK1001").Value
        .Range("A9992:G10990").Value = .Range("GL3:GR1001").Value
        .Range("A10991:G11989").Value = .Range("GS3:GY1001").Value
        .Range("A11990:G12988").Value = .Range("GZ3:HF1001").Value
        .Range("A12989:G13987").Value = .Range("HG3:HM1001").Value
        .Range("A13988:G14986").Value = .Range("HN3:HT1001").Value
        .Range("A14987:G15985").Value = .Range("HU3:IA1001").Value
        .Range("A15986:G16984").Value = .Range("IB3:IH1001").Value
        .Range("A16985:G17983").Value = .Range("II3:IO1001").Value
        .Range("A17984:G18982").Value = .Range("IP3:IV1001").Value
        .Range("A18983:G19981").Value = .Range("IW3:JC1001").Value
        .Range("A19982:G20980").Value = .Range("JD3:JJ1001").Value
        .Range("A20981:G21979").Value = .Range("JK3:JQ1001").Value
        .Range("A21980:G22978").Value = .Range("JR3:JX1001").Value
        .Range("A22979:G23977").Value = .Range("JY3:KE1001").Value
        .Range("A23978:G24976").Value = .Range("KF3:KL1001").Value
        .Range("A24977:G25975").Value = .Range("KM3:KS1001").Value
        .Range("A25976:G26974").Value = .Range("KT3:KZ1001").Value
        .Range("A26975:G27973").Value = .Range("LA3:LG1001").Value
        .Range("A27974:G28972").Value = .Range("LH3:LN1001").Value
        .Range("A28973:G29971").Value = .Range("LO3:LU1001").Value
    End With
    On Error Resume Next
    Range("A:A").SpecialCells(xlBlanks).EntireRow.Delete
    On Error GoTo 0
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
 
Upvote 0
No difference was noticed.
I think the problem is processing 29,971 lines
I split the code to understand what caused it to crash.
Both the part of copying all rows and columns and eliminating empty rows take time but separate
Is there a way to change the code to copy the lines
Ex:
Sheets("Components").Range("A2:G1000").Value = Range("DT3:DZ1001").Value
Sheets("Components").Range("A1001:G1999").Value = Range("EA3:EG1001").Value
If you change this to copy only up to the last cell with data in column A of the "Compounds" sheet and paste it in the first free line of the "Components" sheet, I think the code will run much better.
 
Upvote 0
TRy this code.
VBA Code: 
Sub TransferData()
Dim A, T&, K&, Ros&
A = Sheets("Sheet1").Range("DT3:LU1001")
K = Evaluate("Columns(DT3:LU3)/7"): Ros = Evaluate("Rows(DT3:LU1001)")
Application.ScreenUpdating = False
For T = 1 To K
Sheets("Componentes").Range("A2:G1000").Offset(999 * (T - 1), 0).Value = Application.Index(A, Evaluate("row(1:" & Ros & ")"), Evaluate("transpose(Row(" & 1 + 7 * (T - 1) & ":" & 7 * T & "))"))
Next T
 On Error Resume Next
    [A:A].AutoFilter Field:=1, Criteria1:="="
    [A2:A29971].SpecialCells(xlVisible).EntireRow.Delete
    If [A1] = "" Then [1:1].Delete
    ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
 
Upvote 1
Solution
uauuuuuuuuuuuuuuuuuuuuuuuuuuu
Thank you very much.
The code is spectacular.




kvsrinivasamurthy said:
TRy this code.
VBA Code: 
Sub TransferData()
Dim A, T&, K&, Ros&
A = Sheets("Sheet1").Range("DT3:LU1001")
K = Evaluate("Columns(DT3:LU3)/7"): Ros = Evaluate("Rows(DT3:LU1001)")
Application.ScreenUpdating = False
For T = 1 To K
Sheets("Componentes").Range("A2:G1000").Offset(999 * (T - 1), 0).Value = Application.Index(A, Evaluate("row(1:" & Ros & ")"), Evaluate("transpose(Row(" & 1 + 7 * (T - 1) & ":" & 7 * T & "))"))
Next T
 On Error Resume Next
    [A:A].AutoFilter Field:=1, Criteria1:="="
    [A2:A29971].SpecialCells(xlVisible).EntireRow.Delete
    If [A1] = "" Then [1:1].Delete
    ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
187
VanGirl
V
B
  • Question
VBA code to cut and paste multiple filtered rows based on multiple criteria
Replies
2
Views
638
Alex Blakenburg
A
S
  • Question
Date formatting issue sheet to VBA Array to Sheet
Replies
2
Views
212
MARK858
MARK858
Guna13
  • Question
How to Efficient way for create Multiple Workbooks
Replies
1
Views
189
Guna13
Guna13
M
  • Question
Table issue with VBA
Replies
2
Views
149
Mike2
M

Forum statistics

Threads
1,216,113
Messages
6,128,905
Members
449,478
Latest member
Davenil

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top