Copy range of Headers and paste to next available columns

radsok8199

New Member
Joined
Dec 4, 2020
Messages
24
Office Version
  1. 2016
Platform
  1. Windows
  2. MacOS
  3. Mobile
Dear VBA Masters. I want to used existing1 set of headers to create another 2 sets of headers on same worksheet with same headers using VBA.
So existing headers and target destination always in row 1. Amount of headers will change every week so Copy range need to be dynamic.
Code need to copy existing range of headers (from D1 to last column), then paste into the next empty column ( not first empty). So in final i will have 3 sets of headers with 2 empty columns between
So to create 3 sets of headers I need to used this code twice. Below code I managed works absolutely great and creates 1 set of headers at the time. I could possibly change it to create 2 sets in same time - no problem at all. However before second set is created i need to run another code that will have conflict with 3rd set of headers.
So below code creates 1 set of headers at the time.
Once another code will get completed on same worksheet I want to run same code and create 3rd set of headers after 2nd set with 1 empty column gap.
So when i run this code again it works almost ok. It finds range that need to be copied, it finds target range and paste headers. However when i run it it creates 2 set of headers. So once this is completed i do have : 1 st set, 2nd set, 3rd set and 4th set.
I don't get it why ?
When i run it to create 2nd set it creates only 1 set, then it creates 2 sets ?
Any idea?
VBA Code:
Sub CreateHeaders()

Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim rng As Range
    Dim LastCol As Long
    Dim LastColumn As String
    Dim NextColInput As Long
    

    Set ws = ThisWorkbook.Sheets("Headers")


    With ws
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        NextColInput = LastCol + 2

        LastColumn = Split(.Cells(, LastCol).Address, "$")(1)

        Set rng = .Range("D1:" & LastColumn & "1")

        Debug.Print rng.Address

        rng.Copy
        Sheets("Headers").Cells(1, NextColInput).PasteSpecial Paste:=xlPasteValues
  
        Application.CutCopyMode = False 'clear clipboard

    End With
    
  End Sub
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,562
Office Version
  1. 365
Platform
  1. Windows
Do you have any blank cells in the header row?
 

radsok8199

New Member
Joined
Dec 4, 2020
Messages
24
Office Version
  1. 2016
Platform
  1. Windows
  2. MacOS
  3. Mobile
Do you have any blank cells in the header row?
Yes and no :). Headers itself don have any blank cell between. There is a blank column between first set of headers ( source ) and second set. So when i run code it finds empty column after second set of headers and paste values to the next empty columns. And it does twice like that :)
This is example
1st screen is my 1st set of headers. From here values are copied.
1.PNG


2nd screen show 2 sets after i run code 1st time.
2.PNG


3rd screen shows what happens after code is run 2nd time. It creates one extra set. There should be 3 sets in total.
3.PNG


Any idea?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,562
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
VBA Code:
Sub CreateHeaders()

Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim rng As Range
    Dim LastCol As Long
    Dim LastColumn As String
    Dim NextColInput As Long
    

    Set ws = ThisWorkbook.Sheets("Headers")


    With ws
        LastCol = .Cells(1, 4).End(xlToRight).Column
        NextColInput = .Cells(1, Columns.Count).End(xlToLeft).Column + 2


        Set rng = .Range("D1", .Cells(1, LastCol))

        Debug.Print rng.Address

        rng.Copy
        .Cells(1, NextColInput).PasteSpecial Paste:=xlPasteValues
  
        Application.CutCopyMode = False 'clear clipboard

    End With
    
  End Sub
 
Solution

radsok8199

New Member
Joined
Dec 4, 2020
Messages
24
Office Version
  1. 2016
Platform
  1. Windows
  2. MacOS
  3. Mobile
Ok, how about
VBA Code:
Sub CreateHeaders()

Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim rng As Range
    Dim LastCol As Long
    Dim LastColumn As String
    Dim NextColInput As Long
   

    Set ws = ThisWorkbook.Sheets("Headers")


    With ws
        LastCol = .Cells(1, 4).End(xlToRight).Column
        NextColInput = .Cells(1, Columns.Count).End(xlToLeft).Column + 2


        Set rng = .Range("D1", .Cells(1, LastCol))

        Debug.Print rng.Address

        rng.Copy
        .Cells(1, NextColInput).PasteSpecial Paste:=xlPasteValues
 
        Application.CutCopyMode = False 'clear clipboard

    End With
   
  End Sub
Yes it works. Great thanks. However i just modified it using LastC = sht.ListObjects("Table1").Range.Columns.Count. I have create tables around existing headers and used Table1 and Table2 to achieve this. I do seems to learn fasters since study this Forum :)
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,562
Office Version
  1. 365
Platform
  1. Windows
Glad to help & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,592
Messages
5,637,290
Members
416,962
Latest member
samfuge

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top