copying and pasting data from sheet 1 to sheet 2 in VBA

[jmkelly1988]

Alright I've figured out a lot of ways to copy and paste data, but none work how I want them to.

If I have set cells and ranges from sheet 1:

B3,B10,B17,B24,B31,B38,B45(Cells)
C2:H7,C9:H14,C16:H21:C23:H28
C30:H35,C37:H42,C44:H49(Ranges)

And want to copy to sheet2 in the following fashion:

B3 to A3, B10 to E3, B17 to I3, B24 to M3, B31 to Q3, B38 to U3, B45 to Y3

C2:H7 to A4:D9, C9:H14 to E4:H9, C16:21 to I4:L9, C23:H28 to M4:P9, C30:H35 to Q4:T9, C37:H35 to U4:X9, C44;H49 to Y4:AB9

That part is easy...the problem I'm running into is after this pastes (which is by clicking a command button). I would like it to then to increment by 8 where it pastes next time.

This is being pasted to a calendar so there are dates in increments of 8(start in row 2 and then in row 10 the 18 and so on).

If anyone can help me I would absolutely love them forever!!!

 

[jmkelly1988]

Private Sub CommandButton12_Click()
    Dim ws, ws1 As Worksheet
    Set ws = Sheets("Programmer")
    Set ws1 = Sheets("WOD Calendar")
    
    Sheets("WOD Calendar").Select
    ws1.Range("A3").Select
Start:
 If ActiveCell = "" Then
    ws.Range("V1").Copy
    ws1.Range("A3").PasteSpecial Paste:=xlValues
    ws.Range("X3:X8").Copy
    ws1.Range("A4:A9").PasteSpecial Paste:=xlValues
    ws.Range("U3:U8").Copy
    ws1.Range("B4:B9").PasteSpecial Paste:=xlValues
    ws.Range("V3:V8").Copy
    ws1.Range("C4:C9").PasteSpecial Paste:=xlValues
    ws.Range("W3:W8").Copy
    ws1.Range("D4:D9").PasteSpecial Paste:=xlValues
ElseIf ActiveCell.Offset(8, 0).Select Then GoTo Start

End If

 

[jmkelly1988]

What I have thus far but as you can see it only pastes in rows 3-11 without incrementing.

 

[My Aswer Is This]

Some one would probable need some sort of trend as to what is happening here.
Are you just incrementing the rows or the columns also.

With out some reasoning this would some challenge for sure I would think.

 

[jmkelly1988]

The cells and ranges from sheet1 change weekly and are always different so when I paste the next week to sheet2 I need the same cells to from sheet 1 to be pasted 8 rows downs from A3 then then next week it would be 8 rows from A11 then next week A 19 and forever increments of 8. Does this help?

 

[JLGWhiz]

This might work

Sub t()
Dim fmAry As Variant, toAry As Variant, cyc As Long, sh1 As Worksheet, sh2 As Worksheet, x As Long
Set sh1 = Sheets(1)
Set sh2 = Sheets(2)
cyc = Application.InputBox("Enter the number of iteration to copy and paste.", "HOW MANY COPY CYCLES")
fmAry = Array("B3", "B10", "B17", "B24", "B31", "B38", "B45", "C2:H7", "C9:H14", "C16:H21", "C23:H28", "C30:H35", "C37:H42", "C44:H49")
toAry = Array("A3", "E3", "I3", "M3", "Q3", "U3", "Y3", "A4:D9", "E4:H9", "I4:L9", "M4:P9", "Q4:T9", "U4:X9", "Y4:AB9")
For i = 1 To cyc
    For j = LBound(fmAry) To UBound(fmAry)
        With ActiveSheet
            If i = 1 Then
                sh1.Range(fmAry(j)).Copy sh2.Range(toAry(j))
            Else
                
                sh1.Range(fmAry(j)).Copy sh2.Range(toAry(j)).Offset(x)
            End If
        End With
    Next
    x = x + 8
Next
End Sub

 

[jmkelly1988]

I will try this as soon as I'm in front of a computer, thank you both for the quick replies!

 

[JLGWhiz]

I will try this as soon as I'm in front of a computer, thank you both for the quick replies!

It would be better if you try this one when you get to your computer. I re-read your specs and believe this is what you really want.

Sub t()
Dim fmAry As Variant, toAry As Variant, lr As Long, sh1 As Worksheet, sh2 As Worksheet, x As Long
Set sh1 = Sheets(1)
Set sh2 = Sheets(2)
With sh2
    If .Range("A3") = "" Then
        lr = 3
        x = lr
        y = lr + 1
    Else
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
    End If
    If lr > 3 Then
        x = lr + 2
        y = lr + 3
    End If
End With
fmAry = Array("B3", "B10", "B17", "B24", "B31", "B38", "B45", "C2:H7", "C9:H14", "C16:H21", "C23:H28", "C30:H35", "C37:H42", "C44:H49")
toAry = Array("A" & x, "E" & x, "I" & x, "M" & x, "Q" & x, "U" & x, "Y" & x, "A" & y, "E" & y, "I" & y, "M" & y, "Q" & y, "U" & y, "Y" & y)
    For j = LBound(fmAry) To UBound(fmAry)
        sh1.Range(fmAry(j)).Copy sh2.Range(toAry(j))
    Next
End Sub

I noticed that some of your ranges appear to be out of sync. so you might want to do some editing on that.

 

[jmkelly1988]

This works perfectly from what I can tell. I only have one issue now. When it copies over I would like just the values not all the formatting. Isn't that just .values?

 

[JLGWhiz]

This works perfectly from what I can tell. I only have one issue now. When it copies over I would like just the values not all the formatting. Isn't that just .values?

This would paste values only.

Sub t2()
Dim fmAry As Variant, toAry As Variant, lr As Long, sh1 As Worksheet, sh2 As Worksheet, x As Long
Set sh1 = Sheets(1)
Set sh2 = Sheets(2)
With sh2
    If .Range("A3") = "" Then
        lr = 3
        x = lr
        y = lr + 1
    Else
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
    End If
    If lr > 3 Then
        x = lr + 2
        y = lr + 3
    End If
End With
fmAry = Array("B3", "B10", "B17", "B24", "B31", "B38", "B45", "C2:H7", "C9:H14", "C16:H21", "C23:H28", "C30:H35", "C37:H42", "C44:H49")
toAry = Array("A" & x, "E" & x, "I" & x, "M" & x, "Q" & x, "U" & x, "Y" & x, "A" & y, "E" & y, "I" & y, "M" & y, "Q" & y, "U" & y, "Y" & y)
    For j = LBound(fmAry) To UBound(fmAry)
        sh1.Range(fmAry(j)).Copy
        sh2.Range(toAry(j)).PasteSpecial xlPasteValues
    Next
End Sub