Copying every row of one sheet to the 4th row of another sheet

[Vineshan]

Hi All

I am new to Chandoo.org. I am needing some assistance please, if possible. I have a sheet with Data in column A. I need to take the value from $A$1 and add it to a second sheet but over 3 rows. The 4th row of ColumnA in my second sheet must then read the value from $A$2 and the 7th row in ColumnA must read the value from the 3rd in my first sheet. So basically, I need to copy $A$1 three times and then copy $A$2 three times and so on. I am basically trying to create an excel template (sheet2) to read off sheet1. I need to do this for many columns and I need to be able to accomodate for more data in sheet1 row 1 as well. I am looking for the simplest, most efficient way of populating my second sheet without having to work on every 3rd cell for every column. I have attached a simple file with what is required. Any assistance would be greatly appreciated.

 

[AlanSidman]

Here is some VBA code to do that:

Option Explicit

Sub EveryThree()
    Application.ScreenUpdating = False
    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("ExportPayroll-1531479081800")
    Set s2 = Sheets("Sheet2")
    Dim lr As Long, lr2 As Long
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    Dim i As Long, j As Long
    For i = 2 To lr
        lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
        s1.Range("A" & i).Copy s2.Range("A" & lr2 + 3)
    Next i
    lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
    For i = 5 To lr2 + 2
        If s2.Range("A" & i) = "" Then
            s2.Range("A" & i) = s2.Range("A" & i - 1)
        End If
    Next i
    s2.Range("A2:A3").EntireRow.Delete
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "complete"
End Sub

 

[Vineshan]

Thank you very much for this code. Works brilliantly except for the fact that initially, all the data comes through perfectly but when going back and forth into the sheet, the update removes the top two codes meaning, when clearing the sheet manually and then opening the sheet, code 166 appears 3 times as required. When navigating away from the sheet and then clicking back into the sheet, 166 now appears once. Navigate away and then back in and the next code appears twice now and so on. I will look to resolve this within the code. Thanks a lot for your help.

 

[Vineshan]

Thank you very much. I have resolved my issue and got my desired output. Tiny changes made to the code got me to my perfect result.

Sub EveryThree()

Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("ExportPayroll-1531479081800")
Set s2 = Sheets("Sheet1")
Dim lr As Long, lr2 As Long
lr = s1.Range("A" & Rows.Count).End(xlUp).Row
'Added the following code to clear the sheet as all of the data wasn't being deleted
s2.Range("A2:A5000").EntireRow.Delete
Dim i As Long, j As Long
For i = 2 To lr
lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
'Added the following code to ensure that the rows with no or blank data still comes through, although as 0
If IsNull(s1.Range("A" & i)) = True Then
s1.Range("A" & i).Value = 0
ElseIf (s1.Range("A" & i)) = "" Then
s1.Range("A" & i).Value = 0
End If
s1.Range("A" & i).Copy s2.Range("A" & lr2 + 3)
Next i
lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lr2 + 2
If s2.Range("A" & i) = "" Then
s2.Range("A" & i) = s2.Range("A" & i - 1)
End If
Next i
s2.Range("A2:A3").EntireRow.Delete
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub


Thank you once again.

 

[Marc L]

Hi !

As per forum rules use code tags or the code icon
and next time for a VBA code create your thread
in the appropriate VBA forum, thanks !
​

 

[Marc L]

According to your original post and its attachment,

as a very beginner starter :​

Sub Demo1()
    Dim W, V, R&, L&
        W = Worksheets(1).UsedRange.Columns(1).Value
        ReDim V(1 To (UBound(W) - 1) * 3, 0)
    For R = 2 To UBound(W)
         If W(R, 1) = "" Then W(R, 1) = 0
        V(L + 1, 0) = W(R, 1)
        V(L + 2, 0) = W(R, 1)
        V(L + 3, 0) = W(R, 1)
                  L = L + 3
    Next
    With Worksheets(2)
        .UsedRange.Offset(1).Clear
        .[A2].Resize(L) = V
    End With
End Sub

Or as a beginner starter :​

Sub Demo2()
    Dim W, V, R&, L&
        W = Evaluate(Replace("IF(#>0,#,0)", "#", Worksheets(1).UsedRange.Columns(1).Address(External:=True)))
        ReDim V(1 To (UBound(W) - 1) * 3, 0)
    For R = 2 To UBound(W)
        V(L + 1, 0) = W(R, 1)
        V(L + 2, 0) = W(R, 1)
        V(L + 3, 0) = W(R, 1)
                  L = L + 3
    Next
    With Worksheets(2)
        .UsedRange.Offset(1).Clear
        .[A2].Resize(L) = V
    End With
End Sub

Do you like it ? So thanks to click on bottom right Like !
​