helping to make code a quick

alhagag · Apr 26th 2020

hello

i need help to make this code so faster recently is so slow i appreciate if anybody help

Code

Sub Macro1()

    Dim wsInput As Worksheet, wsOutput As Worksheet
    Dim lngStartRow As Long
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim lngPasteRow As Long
    Dim lngLoop As Long
    Dim xlnCalcMethod As XlCalculation
    
    With Application
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set wsInput = ThisWorkbook.Sheets("Sheet1") 'Name of input (source) data sheet. Change to suit.
    Set wsOutput = ThisWorkbook.Sheets("Sheet2") 'Name of output (destination) data sheet. Change to suit.
    lngStartRow = 3 'Starting row number for the data for both sheets. Change to suit.
    lngLastRow = wsInput.Range("A:M").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lngPasteRow = lngStartRow
    
    For lngMyRow = lngStartRow To lngLastRow
        For lngLoop = 1 To wsInput.Range("L" & lngMyRow)
            wsInput.Range("A" & lngMyRow & ":M" & lngMyRow).Copy Destination:=wsOutput.Range("B" & lngPasteRow)
            wsOutput.Range("A" & lngPasteRow).Value2 = lngLoop
            wsOutput.Range("N" & lngPasteRow).Value2 = Evaluate("G" & lngPasteRow) + lngLoop
            lngPasteRow = lngPasteRow + 1
        Next lngLoop
        lngPasteRow = lngPasteRow + 2
    Next lngMyRow
    
    With Application
        .Calculation = xlnCalcMethod
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

Display More

Mumps · Apr 26th 2020

It would be easier to help and test possible solutions if you could attach a copy of your file. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

alhagag · Apr 26th 2020

my code does divide data to many rows from sheet1 to sheet2 it based on col f,g,l i run this code to understand how it works

**royUK** · Apr 27th 2020

This code is the obvious way to speed it up.

Code

For lngMyRow = lngStartRow To lngLastRow
For lngLoop = 1 To wsInput.Range("L" & lngMyRow)
wsInput.Range("A" & lngMyRow & ":M" & lngMyRow).Copy Destination:=wsOutput.Range("B" & lngPasteRow)
wsOutput.Range("A" & lngPasteRow).Value2 = lngLoop
wsOutput.Range("N" & lngPasteRow).Value2 = Evaluate("G" & lngPasteRow) + lngLoop
lngPasteRow = lngPasteRow + 1
Next lngLoop
lngPasteRow = lngPasteRow + 2
Next lngMyRow

Why are you copying and pasting by rows? I'm not even sure what it is supposed to do.

alhagag · Apr 27th 2020

thanks ROYUK but doesn't change any thing it is still so slow attach my anew file to test it

**royUK** · Apr 27th 2020

I haven't changed anything! That is the slow code, but you haven't ansered my question

alhagag · Apr 27th 2020

sorry i though you changed some thing actually i copy and past without see the changes my code it depends divide my data into many rows based on specific columns

JohnCoulter · Apr 27th 2020

Hi alhagag,

Would I be correct in saying that your code is supposed to loop through each row on Sheet1 and create as many rows as the value in column L and then have the Date column "N" on sheet2 be every date between Enter and Exit Date, and column A on Sheet2 be the current count of loop on the value in column L ?

alhagag · Apr 27th 2020

yes JohnCoulter this exactly what code works

JohnCoulter · Apr 27th 2020

Here's my attempt using arrays, output formating isn't great though

Code

Sub Macro2()
 Dim wsInput As Worksheet, wsOutput As Worksheet
 Dim xlnCalcMethod As XlCalculation
 Dim arRawData(), arOutput(), arTranspose()
 Dim lngRow As Long, lngDays As Long, lngCurrentOutputRow As Long
 Dim lngCol As Long
 
 With Application
 xlnCalcMethod = .Calculation
 .Calculation = xlCalculationManual
 .EnableEvents = False
 .ScreenUpdating = False
 End With
 
 Set wsInput = ThisWorkbook.Sheets("Sheet1") 'Name of input (source) data sheet. Change to suit.
 Set wsOutput = ThisWorkbook.Sheets("Sheet2") 'Name of output (destination) data sheet. Change to suit.
 
 ReDim arOutput(1 To 14, 1 To 1)
 
 arRawData = wsInput.Range("A3:M" & wsInput.Range("A:M").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row).Value
 
  For lngRow = LBound(arRawData, 1) To UBound(arRawData, 1)
 
    For lngDays = 1 To arRawData(lngRow, 12)
        
        ReDim Preserve arOutput(1 To 14, 1 To lngCurrentOutputRow + 1)
        
        For lngCol = LBound(arRawData, 2) To UBound(arRawData, 2)
        
            arOutput(lngCol + 1, lngCurrentOutputRow + 1) = arRawData(lngRow, lngCol)
        
        Next lngCol
        
        arOutput(1, lngCurrentOutputRow + 1) = lngDays
        arOutput(14, lngCurrentOutputRow + 1) = DateAdd("d", lngDays, arRawData(lngRow, 6))
        
        lngCurrentOutputRow = lngCurrentOutputRow + 1
    
    Next lngDays
 
 Next lngRow
 
 ReDim arTranspose(LBound(arOutput, 2) To UBound(arOutput, 2), LBound(arOutput, 1) To UBound(arOutput, 1))
 
 For lngRow = LBound(arOutput, 2) To UBound(arOutput, 2)
    For lngCol = LBound(arOutput, 1) To UBound(arOutput, 1)
        
        arTranspose(lngRow, lngCol) = arOutput(lngCol, lngRow)
    
    Next lngCol
 Next lngRow
 
 arOutput() = arTranspose()
 Erase arTranspose
 
 wsOutput.Range("A3:N" & UBound(arOutput, 1) + 2).Value = arOutput()
 
 wsOutput.Range("B2:N2").Value = wsInput.Range("A2:M2").Value
 wsOutput.Range("A2").Value = "ITEM"
 
 
 With Application
 .Calculation = xlnCalcMethod
 .EnableEvents = True
 .ScreenUpdating = True
 End With

Display More

alhagag · Apr 27th 2020

your code is perfect and i would just simple adjusting insert empty row between every process

JohnCoulter · Apr 27th 2020

to add a line break you could change

Code

    Next lngDays

 Next lngRow

to

Code

    Next lngDays
    
    lngCurrentOutputRow = lngCurrentOutputRow + 1
 
 Next lngRow

alhagag · Apr 27th 2020

i note this error in the lastrow do you have any idea

JohnCoulter · Apr 27th 2020

Code

 wsOutput.Range("A3:N" & UBound(arOutput, 1) + 3).Value = arOutput()

should be

Code

wsOutput.Range("A3:N" & UBound(arOutput, 1) + 2).Value = arOutput()

delete data on sheet2 prior to rerunning

alhagag · Apr 27th 2020

awesome, now your code completely works thank you so much and i appreciate your efforts and your time

have a good day

helping to make code a quick

Participate now!

Share