Macro for Copy/Pasting a sequence of columns

[ericvanlooy]

Hi,

I would greatly appreciate it if you could help (and teach!) this Newbie to macros with the following issue:

I have a workbook with multiple columns containing consolidated data, of which the content needs to be split up into a number of new workbooks.

The data that needs to be copied/pasted into the new workbooks follows a pattern, which I'm sure can be programmed into a Macro.

For instance:
The first 4 columns are always copied into the new workbooks, but column 5 will be variable:
- New workbook 1 will also contain the values from column E
- New workbook 2 will also contain the values from column H (E+3)
- New workbook 3 will also contain the values from column K (E+6)
- New workbook 4 will also contain the values from column N (E+9)

etc...

The copy/paste macro needs to end when the value in row 1 of the 5th column is called "Source"

For now, I have a very manual Macro (based on a recording), but I have a number of Workbooks (with an unequal amount of columns) I would like to apply this Macro on.

This is what I have to give you an idea:


Dim thisWb As Workbook

Set thisWb = ActiveWorkbook

Application.DisplayAlerts = False
Columns("A:E").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
ChDir _
thisWb.Path
ActiveWorkbook.SaveAs Filename:= _
thisWb.Path & "" & _
thisWb.ActiveSheet.Name & "-" & ActiveSheet.Range("E1").Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
thisWb.Activate
Range("A:D,H:H").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
ChDir _
thisWb.Path
ActiveWorkbook.SaveAs Filename:= _
thisWb.Path & "" & _
thisWb.ActiveSheet.Name & "-" & ActiveSheet.Range("E1").Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
thisWb.Activate
Range("A:D,K:K").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
ChDir _
thisWb.Path
ActiveWorkbook.SaveAs Filename:= _
thisWb.Path & "" & _
thisWb.ActiveSheet.Name & "-" & ActiveSheet.Range("E1").Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close

thisWb.Close
Application.DisplayAlerts = True
End Sub


Thanks in advance for your help!

 

[mumps]

Can you clarify what you mean by:

The copy/paste macro needs to end when the value in row 1 of the 5th column is called "Source"

You want columns A:D in all workbooks. Are the fifth columns not always H, K and N? I'm not sure where the

5th column is called "Source"

fits in.

 

[Fluff]

Hi & welcome to the board.
Try this

Sub Copy2NewBook()
    Dim thisWs As Worksheet
    Dim Pth As String
    Dim Rng As Range
    Dim Cnt As Long
    
    Pth = ThisWorkbook.path
    Set thisWs = ActiveSheet
    
Application.DisplayAlerts = False
Application.ScreenUpdating = False

    Set Rng = Columns("A:D")
    For Cnt = 5 To thisWs.Cells(1, Columns.Count).End(xlToLeft).column Step 3
        Workbooks.Add
        Rng.copy Range("A1")
        thisWs.Columns(Cnt).copy Range("E1")
        ActiveWorkbook.SaveAs FileName:=Pth & "\" & _
            thisWs.Name & "-" & ActiveSheet.Range("E1").Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close , False
    Next Cnt

    thisWb.Close
    Application.DisplayAlerts = True
End Sub

It will copy cols A:D to each new workbook along with col E then H etc till there are no more columns

 

[ericvanlooy]

Can you clarify what you mean by: You want columns A:D in all workbooks. Are the fifth columns not always H, K and N? I'm not sure where the fits in.

I realise it sounds a bit vague.

Yes, all new workbooks will contain columns A:D, but all should have a different 5th column. In the first new workbook, that would be column E, but in the second one that will be H, ... and so on. The fifth column in each new workbook should always be every other 3rd column from the source file (column E for new workbook 1, column H for new workbook 2) until you reach a column where the top cell value is called "Source"

Attached some screenshots that may clarify:

 

[ericvanlooy]

Apologies

Use this link for the screenshots

https://expediacorp-my.sharepoint.c...a_corp_expecn_com/Documents/screenshots?csf=1

 

[wideboydixon]

I don't see anything wrong with Fluff's solution; did you try that? The only possible amendment is a check to see if E1 contains the word "Source" and, if so, exit the For loop.

WBD

 

[Fluff]

Modified version to account for Source

Sub Copy2NewBook()
    Dim thisWs As Worksheet
    Dim Pth As String
    Dim Rng As Range
    Dim Cnt As Long
    Dim FnlCol As Long
    
    Pth = ThisWorkbook.path
    Set thisWs = ActiveSheet
    FnlCol = thisWs.Rows(1).Find("Source", , , xlWhole, , , False, , False)
    
Application.DisplayAlerts = False
Application.ScreenUpdating = False

    Set Rng = Columns("A:D")
    For Cnt = 5 To FnlCol Step 3
        Workbooks.Add
        Rng.copy Range("A1")
        thisWs.Columns(Cnt).copy Range("E1")
        ActiveWorkbook.SaveAs FileName:=Pth & "\" & _
            thisWs.Name & "-" & ActiveSheet.Range("E1").Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close , False
    Next Cnt

    thisWb.Close
    Application.DisplayAlerts = True
End Sub

 

[ericvanlooy]

Worked like a charm! Thanks for your help!

 

[Fluff]

Glad we could help & thanks for the feedback