Copy headers across sheets no longer works.

[Nygie]

I have accumulated, merged and altered code from one location or other to create a little time saving routine that basically has all the data in the 'Sales' tab which is sorted into different tabs based on values found in the 'PayMethod' which is referenced to a column on the 'Sales' tab. It then creates a new tab for each method listed, copies the top row of the 'Sales' tab to the newly created tabs and then sorts the data (copies) into the relevant tabs.
It all worked great until I changed from Excel 2007 to 2016. Mainly it works as it should apart from copying the first row from 'Sales' tab to the newly created tabs. I have looked at it and tried different things to do with the range being copied and even tried a different method I found online but that didn't seem to work either. I have highlighted the line where it appears to be not working. I am at a loss as to why it no longer works and the curiosity is getting the better of me
Does anything look amiss, apart from the appalling formatting of the code

Many thanks
Nigel

Sub DoTheSplits()

    Dim xRg As Excel.Range
    Dim wSh As Excel.Worksheet
    Dim wBk As Excel.Workbook
    Dim ws As Worksheet
    Set wSh = Sheet2
    Set wBk = ActiveWorkbook
    Set ws = Sheet1
    
    Application.ScreenUpdating = False
    For Each xRg In wSh.Range("A2:A6")
        With wBk
            .Sheets.Add after:=.Sheets(.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xRg.Value
            ActiveSheet.Range("A:A").NumberFormat = "dd/mm/yy"
            ActiveSheet.Range("F:M").NumberFormat = "#,##0.00"
            If Err.Number = 1004 Then
              Debug.Print xRg.Value & " already used as a sheet name"
            End If
            On Error GoTo 0
        End With
    Next xRg
    Application.ScreenUpdating = True
    
  [COLOR=rgb(184, 49, 47)]  Sheets.FillAcrossSheets ws.Range("1:1")[/COLOR]

    Dim sh As Worksheet
x = 2
 
Application.ScreenUpdating = False
Do
'Get the agent name from the Employee Roster
With Sheets("PayMethod")
    Agent_name = .Range("A" & x).Value
End With
 
'Set the variable sh to the Agenst's tab
On Error Resume Next
Set sh = Sheets(Agent_name)
On Error GoTo 0
 
'Check the existance of the Agent's Tab
'Do the following only when the Agent's Tab exist
If Not sh Is Nothing Then
    With Sheets("Sales")
        'Find the Agent name in the Sales Tab --> Range D
        Set c = .Range("D:D").Find(Agent_name, LookIn:=xlValues, lookat:=xlWhole)
        i = 2
        If Not c Is Nothing Then
            'If Agent's name found then record the first address
            firstAddress = c.Address
            Do
                'Copy the whole row after row found
                .Rows(c.Row).Copy
 
                With Sheets(Agent_name)
                    'Paste the Copied row to the Agent's Tab --> row 3
                    .Rows(i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
                    i = i + 1
                    
                End With
 
                'Check again the Agent's name in the Sales Tab
                Set c = .Range("D:D").FindNext(c)
 
            'Loop the check until all apperance of Agent's name found in the sales Tab
            Loop While Not c Is Nothing And c.Address <> firstAddress
    
            
        End If
    End With
Else
    'Msg Pop out if the Agent's tab does not exist
    R = MsgBox("Sheets " & Agent_name & " does not Exists", vbOKOnly)
End If
 
'Reset the variable sh
Set sh = Nothing
x = x + 1
'Loop back to get a new agent's name in Employee Roster
Loop While Sheets("PayMethod").Range("A" & x).Value <> ""

Dim colm As Long, StartRow As Long
Dim EndCell As Range
'Dim ws As Worksheet
StartRow = 1
For Each ws In Worksheets
    Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 3)
    If EndCell.Row > StartRow Then EndCell.Resize(, 8).Formula = "=SUM(R" & StartRow & "C:R[-1]C)"
 
Next ws
    
  Dim lastrowSrc As Long
Dim lastrowDest As Long
Dim Range As Range
Dim Tlsum As Double

 'Get last row of data
 lastrowSrc = Sheets("Credit or Debit Card").Range("F" & Rows.Count).End(xlUp).Row
 
 'Get first blank row (last row of data +1)
 lastrowDest = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row + 1
 
 'Copy rows
 Sheets("Credit or Debit Card").Range("A" & lastrowSrc).EntireRow.Copy
 Sheets("Summary").Range("A" & lastrowDest).PasteSpecial Paste:=xlValues
 
 lastrowDest = lastrowDest + 1
 lastrowSrc = Sheets("PayPal Express").Range("F" & Rows.Count).End(xlUp).Row
 Sheets("PayPal Express").Range("A" & lastrowSrc).EntireRow.Copy
 Sheets("Summary").Range("A" & lastrowDest).PasteSpecial Paste:=xlValues

 lastrowDest = lastrowDest + 1
 lastrowSrc = Sheets("Amazon").Range("F" & Rows.Count).End(xlUp).Row
 Sheets("Amazon").Range("A" & lastrowSrc).EntireRow.Copy
 Sheets("Summary").Range("A" & lastrowDest).PasteSpecial Paste:=xlValues
 
 lastrowDest = lastrowDest + 1
 lastrowSrc = Sheets("eBay Credit Card Payment").Range("F" & Rows.Count).End(xlUp).Row
 Sheets("eBay Credit Card Payment").Range("A" & lastrowSrc).EntireRow.Copy
 Sheets("Summary").Range("A" & lastrowDest).PasteSpecial Paste:=xlValues
    
   Sheets("Summary").Range("F6:M6").Select
    Selection.FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)"
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThick
    End With
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
 
End Sub

 

[NoSparks]

Putting the cursor on FillAcrossSheets and hitting the F1 key
vba help indicates you need to include an array of the sheets to work on.

 

[Nygie]

Many thanks, I'll give that a go when I get the chance. Strange how it worked before. I am clueless how that has happened as I have not looked at the code for ages as has just worked.

 

[Nygie]

Well, I followed the help regarding including the array to work on but it gives a error. Runtime error '9' subscript out of range. Using the code below.

x = Array("Sheet1", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7")
Sheets(x).FillAcrossSheets _
Worksheets("Sheet1").Range("A1:M1")
Also tried this, same error.
Sub CopyToAllSheets()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Sheets.FillAcrossSheets ws.Range("1:1")
End Sub

I have tried various solutions found on here and the Web and none work for some reason.
This one, essentially the same as the original code, doesn't even error. Just does nothing.
Sub Test()
Worksheets.FillAcrossSheets Sheet1.[A1:M1]
End Sub
If anyone can spot where I am dropping the ball that would be helpful.
Many thanks
Nigel

 

[NoSparks]

For what you're asking, this should do it.

    Dim arrString As String
    Dim x As Variant
    arrString = ws.Name
   
    Application.ScreenUpdating = False
    For Each xRg In wSh.Range("A2:A6")
        With wBk
            arrString = arrString & "," & xRg.Value
            .Sheets.Add after:=.Sheets(.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xRg.Value
            ActiveSheet.Range("A:A").NumberFormat = "dd/mm/yy"
            ActiveSheet.Range("F:M").NumberFormat = "#,##0.00"
            If Err.Number = 1004 Then
              Debug.Print xRg.Value & " already used as a sheet name"
            End If
            On Error GoTo 0
        End With
    Next xRg
   
    x = Split(arrString, ",")
    Sheets(x).FillAcrossSheets ws.[A1:M1]
    Application.ScreenUpdating = True

 

[NoSparks]

Personally, I wouldn't use FillAcrossSheets and I'd check if sheet name exists prior to adding a new sheet

    Dim sht As Worksheet
    Dim hdrRange As Range
    Set hdrRange = ws.Range("A1:M1")
    
    Application.ScreenUpdating = False
    
    For Each xRg In wSh.Range("A2:A6")
        'check if sheet already exists
        On Error Resume Next    'suppress error notification
        Set sht = Sheets(xRg.Value)
        On Error GoTo 0         're-enable error notification
        If sht Is Nothing Then
            Sheets.Add after:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = xRg.Value
                .Range("A:A").NumberFormat = "dd/mm/yy"
                .Range("F:M").NumberFormat = "#,##0.00"
                hdrRange.Copy .Range("A1")
                .Range("A1").Select                 'so header not left selected
                Application.CutCopyMode = False     'to stop the marching ants
            End With
        Else
            Debug.Print xRg.Value & " already used as a sheet name"
        End If
    Next xRg
    
    Application.ScreenUpdating = True

 

[Nygie]

Thanks NoSparks.
At first it did not work with Set hdrRange up top but when I moved it to just above the use of hdrRange.Copy it worked a treat.
Thanks so much.

 

[NoSparks]

You're welcome, glad I could assist