[SOLVED] Splitting Worksheet to Workbooks

Splitting Worksheet to Workbooks

I have a spreadsheet to split out.

For example I have columns A, B, C and D and I need to split the sheet out so:

1st Workbook - columns A & B
2nd Workbook - columns A & C
3rd Workbook - columns A & D

This is for approximately 350 columns and column A needs to be the constant.

Sub t()
    Dim lc As Long, sh As Worksheet, newSh, ws1 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sheet2")
    Set sh = ActiveSheet
    With sh
        lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
        For i = 1 To lc
            If Application.CountA(.Columns(i)) > 0 Then
            
                Set newSh = Sheets.Add
                ws1.Range("a:a").Copy Range("a:a")
                Intersect(.UsedRange, .Columns(i)).Copy newSh.Range("A1")
                newSh.Copy
            
                ActiveWorkbook.SaveAs newSh.Range("a1").Value & ".xlsx"
                ActiveWorkbook.Close
                Application.DisplayAlerts = False
                newSh.Delete
                Application.DisplayAlerts = True
            End If
        Next
    End With
End Sub

This splits out the individual columns, I need to add column A each time.

Solution

In this bit of code:

ws1.Range("a:a").Copy Range("a:a")
Intersect(.UsedRange, .Columns(i)).Copy newSh.Range("A1")

You output to column A both times. So column A is copied each time, but overwritten by whichever other column you copy. Fix this by outputting to "B1" on the second line.