Code for making New columns of Data in a new file (from the data Copied)

I wrote this which should do what you want. It might prompt if the target file already exists - you need to answer "Yes" to overwrite it else the macro will fail:

Option Explicit
Public Sub CopyDataToMonthlySheet()

Dim lastCol As Long
Dim lastRow As Long
Dim thisCol As Long
Dim thisRow As Long
Dim nextRow As Long
Dim sourceBook As Workbook
Dim sourceSheet As Worksheet
Dim targetBook As Workbook
Dim targetSheet As Worksheet

Set sourceBook = ActiveWorkbook
Set sourceSheet = ActiveSheet
sourceSheet.Copy After:=sourceSheet
Set sourceSheet = Worksheets(sourceSheet.Index + 1)

lastCol = sourceSheet.Cells(2, sourceSheet.Columns.Count).End(xlToLeft).Column
If lastCol > 9 Then
    For thisCol = 19 To lastCol Step 10
        lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, thisCol).End(xlUp).Row
        With sourceSheet.Range(sourceSheet.Cells(2, thisCol - 7), sourceSheet.Cells(lastRow, thisCol))
            .Copy sourceSheet.Cells(sourceSheet.Rows.Count, "B").End(xlUp).Offset(1, 0)
            .ClearContents
        End With
    Next thisCol
End If

lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "I").End(xlUp).Row

Set targetBook = Workbooks.Add
targetBook.SaveAs Replace(sourceBook.FullName, sourceBook.Name, "") & Format(sourceSheet.Range("I2").Value, "mmmm yyyy") & ".xlsx"
Set targetSheet = targetBook.Worksheets(1)

thisCol = 1
nextRow = 2
For thisRow = 3 To lastRow + 1
    If sourceSheet.Cells(thisRow, "I").Value <> sourceSheet.Cells(thisRow - 1, "I").Value Then
        sourceSheet.Range(sourceSheet.Cells(nextRow, "B"), sourceSheet.Cells(thisRow - 1, "C")).Copy
        targetSheet.Cells(1, thisCol).PasteSpecial xlPasteValues
        targetSheet.Cells(1, thisCol).PasteSpecial xlPasteFormats
        nextRow = thisRow
        thisCol = thisCol + 3
    End If
Next thisRow

targetSheet.Range("A1").Resize(1, thisCol).EntireColumn.AutoFit
targetSheet.Range("A1").Select
targetBook.Save
Application.DisplayAlerts = False
sourceSheet.Delete
Application.DisplayAlerts = True

End Sub

WBD

Hi Sir,
Hi Sir,

Urrrgh. Try this instead then:

Option Explicit
Public Sub CopyDataToMonthlySheet()

Dim lastCol As Long
Dim lastRow As Long
Dim thisCol As Long
Dim thisRow As Long
Dim startRow As Long
Dim nextCol As Long
Dim nextRow As Long
Dim lastVal As String
Dim thisVal As String
Dim sourceBook As Workbook
Dim sourceSheet As Worksheet
Dim targetBook As Workbook
Dim targetSheet As Worksheet

Application.ScreenUpdating = False

Set sourceBook = ActiveWorkbook
Set sourceSheet = ActiveSheet

Set targetBook = Workbooks.Add
targetBook.SaveAs Replace(sourceBook.FullName, sourceBook.Name, "") & Format(sourceSheet.Range("I2").Value, "mmmm yyyy") & ".xlsx"
Set targetSheet = targetBook.Worksheets(1)

lastCol = sourceSheet.Cells(2, sourceSheet.Columns.Count).End(xlToLeft).Column
nextCol = 1
lastVal = ""
For thisCol = 9 To lastCol Step 10
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, thisCol).End(xlUp).Row + 1
    startRow = 2
    For thisRow = 2 To lastRow
        thisVal = sourceSheet.Cells(thisRow, thisCol).Value
        If thisVal <> lastVal Then
            If lastVal <> "" Then
                ' Copy this section to the target sheet
                If targetSheet.Cells(1, nextCol).Value = "" Then
                    nextRow = 1
                Else
                    nextRow = targetSheet.Cells(targetSheet.Rows.Count, nextCol).End(xlUp).Row + 1
                End If
                sourceSheet.Range(sourceSheet.Cells(startRow, thisCol - 7), sourceSheet.Cells(thisRow - 1, thisCol - 6)).Copy
                targetSheet.Cells(nextRow, nextCol).PasteSpecial xlPasteValuesAndNumberFormats
                Application.CutCopyMode = False
                If thisVal <> "" Then nextCol = nextCol + 3
            End If
            If thisVal <> "" Then
                startRow = thisRow
                lastVal = thisVal
            End If
        End If
    Next thisRow
Next thisCol

targetSheet.Range("A1").Resize(1, nextCol + 3).EntireColumn.AutoFit
targetSheet.Range("A1").Select
targetBook.Save

Application.ScreenUpdating = True

End Sub

WBD

Hi Sir WideBoyDixon,

Hi Sir WideBoyDixon,