paste data from single sheet to multiple sheet for change in value of particular column

[Tumbad]

I have below requirement:

i have a excel file with single sheet where there is data in 18 columns i.e. A to S starting from Row 3. Row 3 is header and actual data starts from row 4.

I need macro to do following activity.

Sort file on column B.

Column B comprises months-year combination say jan2020 or jan2019 etc

Now depending on column B value, i need data in separate sheet for each month-year combination. This data is dynamic in nature i.e. number of rows for each month-year combination may change and number of month year combinations may change as well. Name of new sheet should be as per column B month-year combination for which data is copied.

Data to be transferred is from column C to R in new sheet from Row 2 (A2:P) and in A1 cell of new sheet to have value as per column S equivalent in sheet1 (source sheet). I have attached screenshots below for refrence.

Original sheet:

Added sheets:
1.

2.

3.

Thanks
Tumbad

 

[vcoolio]

Hello Tumbad,

You could try the following code as a starting point. It's untested though so please test it in a copy of your workbook first.

Option Explicit
Sub Test()

       Dim sht As Worksheet, ws As Worksheet, lr As Long, i As Long
       Dim IdO As Object, key As Variant

       Set sht = Sheet1
       Set IdO = CreateObject("Scripting.Dictionary")
             
Application.ScreenUpdating = False
Application.DisplayAlerts = False
                 
        lr = sht.Range("B" & Rows.Count).End(xlUp).Row
        sht.Range("T4:T" & lr) = "=Text(B4,""MMMM YYYY"")"

        For i = 4 To lr
               If Not IdO.Exists(sht.Range("T" & i).Value) Then
                     IdO.Add sht.Range("T" & i).Value, 1
               End If
        Next i
        
        For Each key In IdO.keys
               If Not Evaluate("ISREF('" & key & "'!A1)") Then
               Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key
               End If
  
                Set ws = Sheets(key)
                With sht.[A3].CurrentRegion
                        .AutoFilter 20, key
                        Union(.Columns("C:R"), .Columns("T")).Copy ws.[A2]
                        ws.[A1] = ws.[Q3]
                        ws.Columns(17).Clear
                        ws.Columns.AutoFit
                        .AutoFilter
                End With
        Next key

sht.Select

Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub

I hope that this helps.

Cheerio,
vcoolio.