More Efficient Looping

[bhsoundman]

Hi All,

I've pieced together this code & although the end result is exactly what I need it to do, I'm sure it's not nearly efficient or fast enough.
The basic set up is some data in column G1:AB24. Each row represents a person & the next 20 columns in that row may or may not have times. If there's a blank row in column G (no name) then that row is skipped entirely.
The version of the data without blank rows gets put into AD1:AX24.
A loop within a loop basically.
Can someone help me streamline this code? Thanks so much!

Sub copy_times()
'
Range("g1").Select
    Dim RowCount As Long
    Dim ColCount As Long
    Dim tmpstr As String
    Dim PrevCell As Range
    Dim Time1 As String
    Dim Time2 As String
    Dim Time3 As String
    Dim Time4 As String
    Dim Time5 As String
    Dim Time6 As String
    Dim Time7 As String
    Dim Time8 As String
    Dim Time9 As String
    Dim Time10 As String
    Dim Time11 As String
    Dim Time12 As String
    Dim Time13 As String
    Dim Time14 As String
    Dim Time15 As String
    Dim Time16 As String
    Dim Time17 As String
    Dim Time18 As String
    Dim Time19 As String
    Dim Time20 As String
    Set PrevCell = ActiveCell
 
    For RowCount = 1 To 25
        tmpstr = ""
        Time1 = ""

        For ColCount = 7 To 7
           tmpstr = tmpstr & Cells(RowCount, ColCount)
           Time1 = Cells(RowCount, ColCount).Offset(0, 1)
           Time2 = Cells(RowCount, ColCount).Offset(0, 2)
           Time3 = Cells(RowCount, ColCount).Offset(0, 3)
           Time4 = Cells(RowCount, ColCount).Offset(0, 4)
           Time5 = Cells(RowCount, ColCount).Offset(0, 5)
           Time6 = Cells(RowCount, ColCount).Offset(0, 6)
           Time7 = Cells(RowCount, ColCount).Offset(0, 7)
           Time8 = Cells(RowCount, ColCount).Offset(0, 8)
           Time9 = Cells(RowCount, ColCount).Offset(0, 9)
           Time10 = Cells(RowCount, ColCount).Offset(0, 10)
           Time11 = Cells(RowCount, ColCount).Offset(0, 11)
           Time12 = Cells(RowCount, ColCount).Offset(0, 12)
           Time13 = Cells(RowCount, ColCount).Offset(0, 13)
           Time14 = Cells(RowCount, ColCount).Offset(0, 14)
           Time15 = Cells(RowCount, ColCount).Offset(0, 15)
           Time16 = Cells(RowCount, ColCount).Offset(0, 16)
           Time17 = Cells(RowCount, ColCount).Offset(0, 17)
           Time18 = Cells(RowCount, ColCount).Offset(0, 18)
           Time19 = Cells(RowCount, ColCount).Offset(0, 19)
           Time20 = Cells(RowCount, ColCount).Offset(0, 20)
        Next ColCount
   

        If tmpstr <> "" Then
   
            Range("ad1").Select
        Do
   
   
    If IsEmpty(ActiveCell) = False Then
        ActiveCell.Offset(1, 0).Select
    End If
    Loop Until IsEmpty(ActiveCell) = True

 ActiveCell.Select
    ActiveCell = tmpstr
    ActiveCell.Offset(0, 1) = Time1
    ActiveCell.Offset(0, 2) = Time2
    ActiveCell.Offset(0, 3) = Time3
    ActiveCell.Offset(0, 4) = Time4
    ActiveCell.Offset(0, 5) = Time5
    ActiveCell.Offset(0, 6) = Time6
    ActiveCell.Offset(0, 7) = Time7
    ActiveCell.Offset(0, 8) = Time8
    ActiveCell.Offset(0, 9) = Time9
    ActiveCell.Offset(0, 10) = Time10
    ActiveCell.Offset(0, 11) = Time11
    ActiveCell.Offset(0, 12) = Time12
    ActiveCell.Offset(0, 13) = Time13
    ActiveCell.Offset(0, 14) = Time14
    ActiveCell.Offset(0, 15) = Time15
    ActiveCell.Offset(0, 16) = Time16
    ActiveCell.Offset(0, 17) = Time17
    ActiveCell.Offset(0, 18) = Time18
    ActiveCell.Offset(0, 19) = Time19
    ActiveCell.Offset(0, 20) = Time20
   
    PrevCell.Select

    Application.CutCopyMode = False

        End If
    Next RowCount
End Sub

 

[MARK858]

Why not just filter out the rows with the blank cells in column G then copy/paste it?

 

[bhsoundman]

Why not just filter out the rows with the blank cells in column G then copy/paste it?

Ultimately, I'll be putting names & times in a variety of cells. This is my test version, so I wanted to make it more simple to test.

 

[DanteAmor]

Try this:

Sub copy_times()
  Dim ar As Range
  Application.ScreenUpdating = False
  For Each ar In Range("G1:G25").SpecialCells(xlCellTypeConstants).Areas
    ar.Resize(, 21).Copy Range("AD" & Range("AD" & Rows.Count).End(xlUp).Row + 1)
  Next
  Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

I'll be putting names & times in a variety of cells

It is not necessary to pass the data through variables, the simplest way is to pass the values directly.

Other example:

Sub copy_times_1()
  Dim i As Long
  For i = 1 To 25
    If Range("G" & i).Value <> "" Then
      Range("AD" & Rows.Count).End(3)(2).Resize(1, 21).Value = Range("G" & i).Resize(1, 21).Value
    End If
  Next
End Sub

 

[MARK858]

Ultimately, I'll be putting names & times in a variety of cells. This is my test version, so I wanted to make it more simple to test.

Making it more simple isn't really going to give you an answer likely to help you, if there is some pattern to how your cells actually are then some code could be suggested but if there is no pattern then it would be hard to code for.

The filter answer I gave for the question you asked in code rather than manually is as below

    Application.ScreenUpdating = False
    
    With Range("G1:AB24")
        .AutoFilter Field:=1, Criteria1:="<>"
        .Copy Range("AD1")
        .AutoFilter
    End With

 

[bhsoundman]

It is not necessary to pass the data through variables, the simplest way is to pass the values directly.

Other example:

Sub copy_times_1()
  Dim i As Long
  For i = 1 To 25
    If Range("G" & i).Value <> "" Then
      Range("AD" & Rows.Count).End(3)(2).Resize(1, 21).Value = Range("G" & i).Resize(1, 21).Value
    End If
  Next
End Sub

This works great! Only problem is that I forgot to mention that the destination cells are not a single range. they'll be spread out in a variety of ranges

 

[bhsoundman]

Making it more simple isn't really going to give you an answer likely to help you, if there is some pattern to how your cells actually are then some code could be suggested but if there is no pattern then it would be hard to code for.

The filter answer I gave for your question in code rather than manually is as below

    Application.ScreenUpdating = False
   
    With Range("G1:AB25")
        .AutoFilter Field:=1, Criteria1:="<>"
        .Copy Range("AD1")
    End With

Thanks for working on this.


There is a pattern. Here's an example of the destinations: A20:A40 would be the names & B20:B40 would be Day 1 Time. A50:A70 would be names again & B50:B70 would be Day 2 Time. So on.

 

[MARK858]

Maybe it would be better if you posted some data using the boards XL2BB addin of both your cells to be copied and the end destination done manually (about 6 lines for the destination), especially as you are now stating different ranges.

 

[DanteAmor]

Only problem is that I forgot to mention that the destination cells are not a single range. they'll be spread out in a variety of ranges

According to your macro the destination is NOT in different ranges.

Then explain how you determine which source cell range goes to which destination cell range.
If you explain it with examples, as Mark commented, we can help you simplify your macro.