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

Tumbad

New Member
Joined
Aug 28, 2019
Messages
30
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:
1609484454186.png

Added sheets:
1.
1609484537851.png


2.
1609484623822.png

3.
1609484655849.png


Thanks
Tumbad
 

Some videos you may like

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,035
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.


VBA Code:
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,263
Messages
5,595,166
Members
413,973
Latest member
leon1974mk

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top