Search code examples
excelvbaperformanceexport

Excel Macro to move data from one sheet to another is very slow

`I get one excel with IDs and associated other IDs in outlined format.
For example
Input
in this image - 5647326 is the main ID and associated ID is 8798965, they are grouped with outlines.

I have requirement where I need to transfer data from this sheet to other sheet in same workbook, in linear format - like in original excel we get main ID in one row and associated IDs in next row, in new sheet main ID and associated ID should be in same row, if there are multiple associated IDs then main ID should be added twice and 2 associated IDs in respective rows like in
Output

We have developed a macro that works fine but is very slow like for 500 lines it takes 4-5 mins. Can anyone help as how I can improve performance of following macro (Starting the input sheet data from A6 as first 5 rows have generic information that can be skipped from transfer to other sheet :

Private Sub Workbook_Open() 
' ' MoveRows Macro ' 
' Keyboard Shortcut: Ctrl+w

Dim lastrow As Long 
Dim lastcol As Long 
Dim i As Integer 
Dim iNewRow As Integer 
Dim ws As Worksheet 
Dim cell As Range
Dim row As Long 
Dim crtLvl As Integer 
Dim rgRow As Range 
Dim orgSelect As Range

lastrow = Sheet1.Cells(Rows.Count, 3).End(xlUp).row 
lastcol = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column

'MsgBox lastrow

'Delete all worksheets other than Sheet1 
Application.DisplayAlerts = False 
For Each ws In Worksheets 
If ws.Name <> "Sheet1" 
Then ws.Delete 
End If 
Next 
Application.DisplayAlerts = True

'Create a new worksheet 
Sheets.Add(after:=Sheet1).Name = "Export" 
With Sheets("Export") 
.Range("A1") = "ID" 
.Range("B1") = "Name" 
.Range("C1") = "Type" 
.Range("D1") = "Owner" 
.Range("E1") = "Task Status" 
.Range("F1") = "Associated Resource ID" 
.Range("G1") = "Associated Resource Name" 
.Range("H1") = "Associated Resource Type" 
.Range("I1") = "Associated Resource Owner" 
.Range("J1") = "Associated Resource Status"

.Range("A1:J1").Interior.ColorIndex = 8
End With

i = 6 
iNewRow = 2 
Dim sht As Worksheet 
Dim Lr As Long 
Dim Lc As Long 
Dim FirstCell As Range
Set sht = Worksheets("Sheet1") 
Set FirstCell = Range("A6") 
Dim inp As Integer 
Dim iFirstLevelRow As Integer

With Sheet1 
For Each cell In .Range("a6", .Cells(lastrow, lastcol)) 
'rg2c = Range(FirstCell, .Cells(i, 1).Select) 
rangeName = i & ":" & i 
rg2c = Worksheets("Sheet1").Range(rangeName)

inp = Worksheets("Sheet1").Rows(i).OutlineLevel 

If i <= lastrow Then
   If inp = 1 Then
   iFirstLevelRow = cell.row
  
        i = i + 1
 End If
  If inp = 2 Then
  .Cells(iFirstLevelRow, 1).Copy Sheets("Export").Cells(iNewRow, 1)
        .Cells(iFirstLevelRow, 2).Copy Sheets("Export").Cells(iNewRow, 2)
        .Cells(iFirstLevelRow, 3).Copy Sheets("Export").Cells(iNewRow, 3)
           .Cells(iFirstLevelRow, 4).Copy Sheets("Export").Cells(iNewRow, 4)
           .Cells(iFirstLevelRow, 5).Copy Sheets("Export").Cells(iNewRow, 5)
           .Cells(iFirstLevelRow, 6).Copy Sheets("Export").Cells(iNewRow, 6)
  .Cells(cell.row, 1).Copy Sheets("Export").Cells(iNewRow, 7)
        .Cells(cell.row, 2).Copy Sheets("Export").Cells(iNewRow, 8)
        .Cells(cell.row, 3).Copy Sheets("Export").Cells(iNewRow, 9)
         .Cells(cell.row, 4).Copy Sheets("Export").Cells(iNewRow, 10)
        i = i + 1
        iNewRow = iNewRow + 1
 End If
 End If

Next

End With

Worksheets("Export").UsedRange.EntireColumn.AutoFit
Worksheets("Export").UsedRange.EntireRow.AutoFit 
End Sub
Solution

  • In response to your reply to my comment - here are ways of using a range. This includes the suggestion from @lorenz albert (upvoted)

    Sub demo()

    'Method 1 - use the Range to copy/paste instead of column by column or row by row
    ThisWorkbook.Sheets("Sheet1").Range("A4:I5").Copy ThisWorkbook.Sheets("Sheet2").Range("A3:I4")

    'Method 2 - assign the values directly
    ThisWorkbook.Sheets("Sheet2").Range("A5:I6").Value = ThisWorkbook.Sheets("Sheet1").Range("A6:I7").Value
    
    'Method 3 - use arrays as an intermediary - useful if you need to examine or amend the contents of any cells first
    Dim vArr As Variant
    vArr = ThisWorkbook.Sheets("Sheet1").Range("A8:I9").Value
    ThisWorkbook.Sheets("Sheet2").Range("A7:I8").Value = vArr

End Sub