Loop across a number of columns

[another rachel]

Hello
I am trying to copy data that it sitting in columns across a spreadsheet in to one long column.
I have a set of base data (A3:D14) that needs to be copied with each set.
I have a date that needs to be copied against each set of data (at the moment I am specifing the range which I doubt will work in a loop - I suspect that I need to use a "filldown" down command but can not work out how to use it if I set the date to be copied to the offset of lastcellcolumnE.
I have a set of data that varies in each column depending on the week.

Any suggestions on the filldown command and the way to loop across 20 columns would be most appreciated (as always).
Rachel

The code is as follows:

Dim lastcellcolumnA As Range
Dim lastcellcolumnF As Range
Dim lastcellcolumnG As Range

'Insert column for date field
    Columns("E:E").Insert Shift:=xlToRight

'Copy date field for week 1
    Range("F2").Select
    Selection.Copy
    Range("E3:E14").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Find the first empty cell in column A and F
    Set lastcellcolumnA = Range("A" & Rows.Count).End(xlUp)
    Set lastcellcolumnF = Range("F" & Rows.Count).End(xlUp)
    Set lastcellcolumnE = Range("E" & Rows.Count).End(xlUp)
    
 'Copy base data (sales org, LPG name & code, account code) for week 2
    Range("A3:D14").Copy
    lastcellcolumnA.Offset(1).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
 
 'Copy date field for week 2
    Range("G2").Copy
    Range("E15:E26").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    'ideally I would like to use something like the following:
    'Range("G2").Copy
    'lastcellcolumnE.Offset(1).PasteSpecial Paste:=xlPasteValues
    'Application.CutCopyMode = False
    'lastcellcolumnE.Offset(1).select
    'Selection.FillDown.11 cells
    
 'Copy volumes for week 2
    Range("G3:G14").Copy
    lastcellcolumnF.Offset(1).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

 'Re-find the first empty cell in column A and F
    Set lastcellcolumnA = Range("A" & Rows.Count).End(xlUp)
    Set lastcellcolumnF = Range("F" & Rows.Count).End(xlUp)
 
  'Copy base data (sales org, LPG name & code, account code) for week 3
    Range("A3:D14").Copy
    lastcellcolumnA.Offset(1).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

  'Copy date field for week 3
    Range("H2").Copy
    Range("E27:E38").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  
  'Copy volumes for week 3
    Range("H3:H15").Copy
    lastcellcolumnF.Offset(1).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

 

[tusharm]

A couple of comments. I assume that each week has 12 rows of data in rows 3:14 and that the reference to H15 was an error. Also, I am not a big fan of modifying existing data. Doing so makes it far more difficult to audit a process or diagnose a problem. The code below reflects my reluctance to modify source data.

While the code (specifically the For control loop) requires at least 2 weeks of data, that restriction is easily removed. The output is a new data range starting one row below the current used range. It can be easily modified to be a new worksheet.

Option Explicit

Sub copyADataSet(BaseData As Range, ADateCell As Range, _
        ByRef DestCell As Range)
    Dim NbrDataRows As Long
    NbrDataRows = BaseData.Rows.Count
    BaseData.Copy
    DestCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    ADateCell.Copy
    DestCell.Offset(0, BaseData.Columns.Count).Resize(NbrDataRows, 1) _
        .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    ADateCell.Offset(1, 0).Resize(NbrDataRows, 1).Copy
    DestCell.Offset(0, BaseData.Columns.Count + 1).PasteSpecial _
        Paste:=xlPasteValuesAndNumberFormats
    Set DestCell = DestCell.Offset(NbrDataRows, 0)
    End Sub
Sub CopyMultiColumnsToOne()
    Dim BaseData As Range, FirstDateCell As Range, _
        ADateCell As Range, DestCell As Range

    Set BaseData = Range("A3:D14")
    Set FirstDateCell = Range("E2")
    With ActiveSheet.UsedRange
    Set DestCell = Cells(.Row + .Rows.Count + 1, 1)
        End With
    For Each ADateCell In Range(FirstDateCell, FirstDateCell.End(xlToRight))
        'The above For requires at least 2 weeks of data to work correctly
        copyADataSet BaseData, ADateCell, DestCell
        Next ADateCell
    End Sub