Reformulate the code so it doesn't crash

PIsabel

PIsabel

Board Regular
Joined
Feb 4, 2014
Messages
126
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

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
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

F
  • Question Question
VBA, Selection with xlToRight but want to end at column JK
Replies
3
Views
140
Joe4
Joe4
T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
306
tixarah
T
L
  • Question Question
Code shuts down excel
Replies
3
Views
357
Peter_SSs
Peter_SSs
F
  • Question Question
VBA Code for Named Ranges
Replies
2
Views
643
fishandtril
F
A
  • Solved
VBA to declare column headers and use in further code
Replies
6
Views
442
AggieJess27
A

Forum statistics

Threads
1,223,909
Messages
6,175,313
Members
452,634
Latest member
cpostell

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