Copy range of Headers and paste to next available columns

[radsok8199]

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?

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

 

[Fluff]

Do you have any blank cells in the header row?

 

[radsok8199]

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.

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

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

Any idea?

 

[Fluff]

Ok, how about

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

 

[radsok8199]

Ok, how about

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]

Glad to help & thanks for the feedback.