Running sub to reformat data onto sheet 2 really slow of get "Excel is not responding"

R

Rolnam

New Member
Joined
Jun 2, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
Hello!
Glad to have found this site. Once upon a time I was a programmer, but really didn't so anything with VBA in excel.
Unfortunately, I believe I am using an overly large hammer to address my challenge with minimal efficiencies.

I ran the code below on the first 1,000 rows in sheet(1) and it ran in around 3 minutes. Output was 1,311 rows in sheet(2). This is really slow.
I need to run this for 60,000 rows - it shouldn't take hours should it?

I am confident there is a more elegant solution.
NOTES:
1. the starting data is a list of time punches; 1 row per person with all their punches for the day. (in, breaks, meals, out)
2. I need the data to be in sheet 2 as one line per set of in /out punches. For most they are part time and just have in and out.
3. since the punch pairs are all left to right (pairs and then blanks) I can check for the blank field to know how many pairs I will be writing to sheet(2).
 

Attachments

  • VBA code - works but slow.png
    VBA code - works but slow.png
    190.5 KB · Views: 9

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Sort by date Sort by votes
Using Value = Value is much faster then copy and paste. Additionally, groups of adjacent cells can be done in a single action rather than individually, again speeding things up. If you post your code to the forum in an editable format then we can set up an example of this based on the sheets and ranges that you are using.

Clicking the </> icon on the reply toolbar will open a window that you can paste your code into so that it is formatted properly in your post.
 
Upvote 0
jasonb75 said:
Using Value = Value is much faster then copy and paste. Additionally, groups of adjacent cells can be done in a single action rather than individually, again speeding things up. If you post your code to the forum in an editable format then we can set up an example of this based on the sheets and ranges that you are using.

Clicking the </> icon on the reply toolbar will open a window that you can paste your code into so that it is formatted properly in your post.
Click to expand...
VBA Code: 
Sub ConvertPunchRow()
    Dim NewRow As Long
    Dim i As Long
    NewRow = 1
    
    For i = 2 To 1000
            If ThisWorkbook.Sheets(1).Cells(i, 5).Value = vbNullString Then
            ' Emp shift info
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 3)
            ' no breaks so just Start and End
                ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 4)
                ThisWorkbook.Sheets(1).Cells(i, 13).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 5)
            NewRow = NewRow + 1
            GoTo ReadNextLine
            ' = = = 1 Break  = = =
            End If
            If ThisWorkbook.Sheets(1).Cells(i, 7).Value = vbNullString Then
            '1st new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 3)
            ' start to 1st break
                ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 4)
                ThisWorkbook.Sheets(1).Cells(i, 5).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 5)
            '2nd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 3)
            ' last shift
                ThisWorkbook.Sheets(1).Cells(i, 6).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 4)
                ThisWorkbook.Sheets(1).Cells(i, 13).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 5)
            NewRow = NewRow + 2
           GoTo ReadNextLine
            
            ' = = = 2 Breaks  = = =
            End If
            If ThisWorkbook.Sheets(1).Cells(i, 9).Value = vbNullString Then
            '==1st new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 3)
            ' start to 1st break
                ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 4)
                ThisWorkbook.Sheets(1).Cells(i, 5).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 5)
            '==2nd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 3)
            ' break end to next break start
                ThisWorkbook.Sheets(1).Cells(i, 6).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 4)
                ThisWorkbook.Sheets(1).Cells(i, 7).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 5)
            '==3rd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 3)
            ' last shift
                ThisWorkbook.Sheets(1).Cells(i, 8).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 4)
                ThisWorkbook.Sheets(1).Cells(i, 13).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 5)
            NewRow = NewRow + 3
           GoTo ReadNextLine
            ' = = = 3 Breaks  = = =
            End If
            If ThisWorkbook.Sheets(1).Cells(i, 11).Value = vbNullString Then
            '==1st new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 3)
            ' start to 1st break
                ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 4)
                ThisWorkbook.Sheets(1).Cells(i, 5).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 5)
            '==2nd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 3)
            ' break end to next break start
                ThisWorkbook.Sheets(1).Cells(i, 6).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 4)
                ThisWorkbook.Sheets(1).Cells(i, 7).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 5)
            '==3rd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 3)
            ' 2nd break end to 3rd break start
                ThisWorkbook.Sheets(1).Cells(i, 8).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 4)
                ThisWorkbook.Sheets(1).Cells(i, 9).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 5)
            '==4th new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 3)
            ' last shift
                ThisWorkbook.Sheets(1).Cells(i, 10).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 4)
                ThisWorkbook.Sheets(1).Cells(i, 13).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 5)
            NewRow = NewRow + 4
            GoTo ReadNextLine
            ' = = = 4 Breaks  = = =
            End If
            If ThisWorkbook.Sheets(1).Cells(i, 11).Value <> vbNullString Then
            '==1st new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 3)
            ' start to 1st break
                ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 4)
                ThisWorkbook.Sheets(1).Cells(i, 5).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 5)
            '==2nd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 3)
            ' break end to next break start
                ThisWorkbook.Sheets(1).Cells(i, 6).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 4)
                ThisWorkbook.Sheets(1).Cells(i, 7).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 5)
            '==3rd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 3)
            ' 2nd break end to 3rd break start
                ThisWorkbook.Sheets(1).Cells(i, 8).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 4)
                ThisWorkbook.Sheets(1).Cells(i, 9).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 5)
            '==4th new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 3)
            ' 3rd break end to 4th break start
                ThisWorkbook.Sheets(1).Cells(i, 10).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 4)
                ThisWorkbook.Sheets(1).Cells(i, 11).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 5)
            '==5th new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 4, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 4, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 4, 3)
            ' last shift
                ThisWorkbook.Sheets(1).Cells(i, 12).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 4, 4)
                ThisWorkbook.Sheets(1).Cells(i, 13).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 4, 5)
            NewRow = NewRow + 5
            End If
ReadNextLine:
    Next i
End Sub
 
Upvote 0
Rolnam said:
VBA Code: 
Sub ConvertPunchRow()
    Dim NewRow As Long
    Dim i As Long
    NewRow = 1
   
    For i = 2 To 1000
            If ThisWorkbook.Sheets(1).Cells(i, 5).Value = vbNullString Then
            ' Emp shift info
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 3)
            ' no breaks so just Start and End
                ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 4)
                ThisWorkbook.Sheets(1).Cells(i, 13).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 5)
            NewRow = NewRow + 1
            GoTo ReadNextLine
            ' = = = 1 Break  = = =
            End If
            If ThisWorkbook.Sheets(1).Cells(i, 7).Value = vbNullString Then
            '1st new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 3)
            ' start to 1st break
                ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 4)
                ThisWorkbook.Sheets(1).Cells(i, 5).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 5)
            '2nd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 3)
            ' last shift
                ThisWorkbook.Sheets(1).Cells(i, 6).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 4)
                ThisWorkbook.Sheets(1).Cells(i, 13).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 5)
            NewRow = NewRow + 2
           GoTo ReadNextLine
           
            ' = = = 2 Breaks  = = =
            End If
            If ThisWorkbook.Sheets(1).Cells(i, 9).Value = vbNullString Then
            '==1st new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 3)
            ' start to 1st break
                ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 4)
                ThisWorkbook.Sheets(1).Cells(i, 5).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 5)
            '==2nd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 3)
            ' break end to next break start
                ThisWorkbook.Sheets(1).Cells(i, 6).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 4)
                ThisWorkbook.Sheets(1).Cells(i, 7).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 5)
            '==3rd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 3)
            ' last shift
                ThisWorkbook.Sheets(1).Cells(i, 8).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 4)
                ThisWorkbook.Sheets(1).Cells(i, 13).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 5)
            NewRow = NewRow + 3
           GoTo ReadNextLine
            ' = = = 3 Breaks  = = =
            End If
            If ThisWorkbook.Sheets(1).Cells(i, 11).Value = vbNullString Then
            '==1st new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 3)
            ' start to 1st break
                ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 4)
                ThisWorkbook.Sheets(1).Cells(i, 5).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 5)
            '==2nd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 3)
            ' break end to next break start
                ThisWorkbook.Sheets(1).Cells(i, 6).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 4)
                ThisWorkbook.Sheets(1).Cells(i, 7).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 5)
            '==3rd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 3)
            ' 2nd break end to 3rd break start
                ThisWorkbook.Sheets(1).Cells(i, 8).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 4)
                ThisWorkbook.Sheets(1).Cells(i, 9).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 5)
            '==4th new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 3)
            ' last shift
                ThisWorkbook.Sheets(1).Cells(i, 10).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 4)
                ThisWorkbook.Sheets(1).Cells(i, 13).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 5)
            NewRow = NewRow + 4
            GoTo ReadNextLine
            ' = = = 4 Breaks  = = =
            End If
            If ThisWorkbook.Sheets(1).Cells(i, 11).Value <> vbNullString Then
            '==1st new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 3)
            ' start to 1st break
                ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 4)
                ThisWorkbook.Sheets(1).Cells(i, 5).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow, 5)
            '==2nd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 3)
            ' break end to next break start
                ThisWorkbook.Sheets(1).Cells(i, 6).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 4)
                ThisWorkbook.Sheets(1).Cells(i, 7).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 1, 5)
            '==3rd new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 3)
            ' 2nd break end to 3rd break start
                ThisWorkbook.Sheets(1).Cells(i, 8).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 4)
                ThisWorkbook.Sheets(1).Cells(i, 9).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 2, 5)
            '==4th new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 3)
            ' 3rd break end to 4th break start
                ThisWorkbook.Sheets(1).Cells(i, 10).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 4)
                ThisWorkbook.Sheets(1).Cells(i, 11).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 3, 5)
            '==5th new row
                ThisWorkbook.Sheets(1).Cells(i, 1).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 4, 1)
                ThisWorkbook.Sheets(1).Cells(i, 2).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 4, 2)
                ThisWorkbook.Sheets(1).Cells(i, 3).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 4, 3)
            ' last shift
                ThisWorkbook.Sheets(1).Cells(i, 12).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 4, 4)
                ThisWorkbook.Sheets(1).Cells(i, 13).Copy Destination:=ThisWorkbook.Sheets(2).Cells(NewRow + 4, 5)
            NewRow = NewRow + 5
            End If
ReadNextLine:
    Next i
End Sub
Click to expand...
thanks for the tip on posting @jasonb75. I am really new to this world, but need to start getting fluent for future work and analysis efforts.
 
Upvote 0
Can you also post a small, anonymised, example of your data.
MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.
 
Upvote 0
So you are saying to use the Value (of destination cell) = Value (of source cell)?
kind of like
ThisWorkbook.Sheets(2).Cells(NewRow, 1).Value = ThisWorkbook.Sheets(1).Cells(i, 1).Value
 
Upvote 0
That's pretty much what I was thinking. You can also use Resize to do a continuous range of cells as a single operation. For example
VBA Code: 
    Dim NewRow As Long, i As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets(1)
    Set ws2 = ThisWorkbook.Worksheets(2)
    NewRow = 1
    
    For i = 2 To 1000
            If ws1.Cells(i, 5).Value = vbNullString Then
            ' Emp shift info
                ws2.Cells(NewRow, 1).Resize(, 4).Value = ws1.Cells(i, 1).Resize(, 4).Value
                ws2.Cells(NewRow, 5).Value = ws1.Cells(i, 13).Value
                NewRow = NewRow + 1
 
Upvote 0
Fluff said:
Can you also post a small, anonymised, example of your data.
MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.
Click to expand...
I believe the Add-in is getting blocked from getting installed here at work. hopefully this short table cut-n-paste can be worked with.

Employee NumberEmployee NameShift DateStart ShiftStart Meal 1End Meal 1Start Meal 2End Meal 2Start Meal 3End Meal 3Start Meal 4End Meal 4End Shift
1234COURTNEY SMITH03/18/202110:02:00 AM12:07:00 PM
1234COURTNEY SMITH03/20/20219:09:00 AM1:08:00 PM
4321BROOKE TWO03/20/202111:15:00 AM8:44:00 PM
4321BROOKE TWO03/21/202111:28:00 AM6:22:00 PM
4321BROOKE TWO03/23/202110:50:00 AM4:06:00 PM4:26:00 PM7:15:00 PM
4321BROOKE TWO03/24/20219:54:00 AM4:35:00 PM4:59:00 PM7:16:00 PM
4321BROOKE TWO03/25/202110:22:00 AM7:41:00 PM
4321BROOKE TWO03/26/202110:54:00 AM5:06:00 PM5:29:00 PM8:03:00 PM
1111WANDA HALES03/14/202111:07:00 AM3:21:00 PM4:47:00 PM9:36:00 PM
1111WANDA HALES03/15/20218:02:00 AM8:37:00 AM8:55:00 AM4:57:00 PM6:09:00 PM10:17:00 PM
1111WANDA HALES03/16/20218:04:00 AM6:08:00 PM
1111WANDA HALES03/17/20218:00:00 AM8:29:00 AM8:50:00 AM5:36:00 PM6:06:00 PM10:40:00 PM
1111WANDA HALES03/18/20215:36:00 AM3:20:00 PM
2222ELIJAH BAKERTON03/27/20211:51:00 PM5:54:00 PM5:56:00 PM8:34:00 PM
3333ALYSSA ONE03/23/202111:01:00 AM4:02:00 PM
3333ALYSSA ONE03/25/20219:27:00 AM2:30:00 PM3:00:00 PM4:30:00 PM
3333ALYSSA ONE03/26/20214:05:00 PM9:32:00 PM
3333ALYSSA ONE03/27/20213:59:00 PM9:21:00 PM
 
Upvote 0
jasonb75 said:
That's pretty much what I was thinking. You can also use Resize to do a continuous range of cells as a single operation. For example
VBA Code: 
    Dim NewRow As Long, i As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets(1)
    Set ws2 = ThisWorkbook.Worksheets(2)
    NewRow = 1
   
    For i = 2 To 1000
            If ws1.Cells(i, 5).Value = vbNullString Then
            ' Emp shift info
                ws2.Cells(NewRow, 1).Resize(, 4).Value = ws1.Cells(i, 1).Resize(, 4).Value
                ws2.Cells(NewRow, 5).Value = ws1.Cells(i, 13).Value
                NewRow = NewRow + 1
Click to expand...
I shall experiment - thanks.
 
Upvote 0
The full edit, untested. I've tried to keep it as simple as possible so that you can hopefully follow it a bit easier.
VBA Code: 
Sub ConvertPunchRow()
    Application.ScreenUpdating = False
    Dim NewRow As Long, i As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets(1)
    Set ws2 = ThisWorkbook.Worksheets(2)
    NewRow = 1
    
    For i = 2 To 1000
        If ws1.Cells(i, 5).Value = vbNullString Then
        ' Emp shift info
            ws2.Cells(NewRow, 1).Resize(, 4).Value = ws1.Cells(i, 1).Resize(, 4).Value
            ws2.Cells(NewRow, 5).Value = ws1.Cells(i, 13).Value
            NewRow = NewRow + 1
    
        ' = = = 1 Break  = = =
        ElseIf ws1.Cells(i, 7).Value = vbNullString Then
            ws2.Cells(NewRow, 1).Resize(, 5).Value = ws1.Cells(i, 1).Resize(, 5).Value
            ws2.Cells(NewRow + 1, 1).Resize(, 3).Value = ws1.Cells(i, 1).Resize(, 3).Value
            ws2.Cells(NewRow + 1, 4).Value = ws1.Cells(i, 6).Value
            ws2.Cells(NewRow + 1, 5).Value = ws1.Cells(i, 13).Value
            NewRow = NewRow + 2
                
        ' = = = 2 Breaks  = = =
    
        ElseIf ws1.Cells(i, 9).Value = vbNullString Then
            ws2.Cells(NewRow, 1).Resize(, 5).Value = ws1.Cells(i, 1).Resize(, 5).Value
            ws2.Cells(NewRow + 1, 1).Resize(, 3).Value = ws1.Cells(i, 1).Resize(, 3).Value
            ws2.Cells(NewRow + 1, 4).Resize(, 2).Value = ws1.Cells(i, 6).Resize(, 2).Value
            ws2.Cells(NewRow + 2, 1).Resize(, 3).Value = ws1.Cells(i, 1).Resize(, 3).Value
            ws2.Cells(NewRow + 2, 4).Value = ws1.Cells(i, 8).Value
            ws2.Cells(NewRow + 2, 5).Value = ws1.Cells(i, 13).Value
            NewRow = NewRow + 3
    
        ' = = = 3 Breaks  = = =
        
        ElseIf ThisWorkbook.Sheets(1).Cells(i, 11).Value = vbNullString Then
            ws2.Cells(NewRow, 1).Resize(, 5).Value = ws1.Cells(i, 1).Resize(, 5).Value
            ws2.Cells(NewRow + 1, 1).Resize(, 3).Value = ws1.Cells(i, 1).Resize(, 3).Value
            ws2.Cells(NewRow + 1, 4).Resize(, 2).Value = ws1.Cells(i, 6).Resize(, 2).Value
            ws2.Cells(NewRow + 2, 1).Resize(, 3).Value = ws1.Cells(i, 1).Resize(, 3).Value
            ws2.Cells(NewRow + 2, 4).Resize(, 2).Value = ws1.Cells(i, 8).Resize(, 2).Value
            ws2.Cells(NewRow + 3, 1).Resize(, 3).Value = ws1.Cells(i, 1).Resize(, 3).Value
            ws2.Cells(NewRow + 3, 4).Value = ws1.Cells(i, 10).Value
            ws2.Cells(NewRow + 3, 5).Value = ws1.Cells(i, 13).Value
            NewRow = NewRow + 4
        
        ' = = = 4 Breaks  = = =
        ElseIf ThisWorkbook.Sheets(1).Cells(i, 11).Value <> vbNullString Then
            ws2.Cells(NewRow, 1).Resize(, 5).Value = ws1.Cells(i, 1).Resize(, 5).Value
            ws2.Cells(NewRow + 1, 1).Resize(, 3).Value = ws1.Cells(i, 1).Resize(, 3).Value
            ws2.Cells(NewRow + 1, 4).Resize(, 2).Value = ws1.Cells(i, 6).Resize(, 2).Value
            ws2.Cells(NewRow + 2, 1).Resize(, 3).Value = ws1.Cells(i, 1).Resize(, 3).Value
            ws2.Cells(NewRow + 2, 4).Resize(, 2).Value = ws1.Cells(i, 8).Resize(, 2).Value
            ws2.Cells(NewRow + 3, 1).Resize(, 3).Value = ws1.Cells(i, 1).Resize(, 3).Value
            ws2.Cells(NewRow + 3, 4).Resize(, 2).Value = ws1.Cells(i, 10).Resize(, 2).Value
            ws2.Cells(NewRow + 4, 1).Resize(, 3).Value = ws1.Cells(i, 1).Resize(, 3).Value
            ws2.Cells(NewRow + 4, 4).Resize(, 2).Value = ws1.Cells(i, 12).Resize(, 2).Value
            NewRow = NewRow + 5
        End If
    Next i
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

T
  • Question
Way too many SUMIFS functions slowing down performance
Replies
4
Views
1K
RoryA
RoryA
O
  • Question
Running through a Config and pulling out the relevant information using keywords into smaller sheets
Replies
0
Views
157
oitbc
O
J
  • Locked
  • Question
Still need help on a daily summary sheet
Replies
1
Views
324
Fluff
Fluff
S
  • Question
Accumulate Data from 10k+ Files. Very Slow. Issue with ActiveWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
2
Replies
10
Views
663
NdNoviceHlp
NdNoviceHlp
A
  • Solved
Finding a unique value in a range and returning the value in another column of the same row, without offset / slow formulae.
Replies
8
Views
1K
AaronPMH
A

Forum statistics

Threads
1,215,455
Messages
6,124,935
Members
449,195
Latest member
Stevenciu

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