VBA Macro to Create Workbooks that Include Specific rows and columns from another Tab

Good afternoon,

I would like to know if there is a VBA macro to create new workbooks which will only include specific data from another tab. In the attached "Example.xlsx" I have identified on the summary tab the workbook name and an ID that corresponds to an ID on multiple rows of the Data Tab. I am looking to run a VBA Macro to create Workbooks 1-5 which I have attached. I am having trouble because the rows on the data tab have duplicated IDs.

thanks,

Adamshl

Hi,

where must be located the VBA procedure, in the source Exemple .xlsx workbook (so to be saved as binary or macro) or ?

I believe I need it saved as a Macro, but I'm not certain. I want the new workbooks to be saved as .xls or .xlsx. Sorry I'm a bit of a VBA newb.

The question is not for the new workbooks but where the code must be saved,
so within the Exemple .xlsx workbook - but in this case it must be saved as .xlsb or as .xlsm - or where ?

So a second question : if the code is not located in the source Exemple .xlsx workbook, is this source workbook already opened ?

Makes sense. I would like it the new workbooks to be saved to my desktop or be able to specify the folder location. No the source workbook is not open.

That's not my question !

But now I know this is not in the source data workbook so it's your stuff but new questions :

• where is located the source workbook in order the VBA procedure can access it ?
  
  
• Can the result workbooks be saved in the same location than the source workbook ?

Sorry, i hope this answers what your looking for.

where is located the source workbook in order the VBA procedure can access it ? - my Desktop

Can the result workbooks be saved in the same location than the source workbook ? - Yes

Last but not least : is it always on Desktop the Exemple. xlsx workbook as the source data to open
or the folder or the workbook name may change ?
If any can change so it's better the procedure ask to choose the source workbook - Explorer like - …

Yes name and path of the source workbook could change.

Ok, now any helper can give it a try …

A VBA starter demonstration :

PHP Code: 

Sub Demo1()
       Const D = "Data", S = "Summary"
         Dim V, L&, P$, Ws(2) As Worksheet
    With Application
         V = .GetOpenFilename("Excel files (*.xlsx), *.xlsx"):  If V = False Then Exit Sub
        .DisplayAlerts = False:     .ScreenUpdating = False
         L = .SheetsInNewWorkbook:  .SheetsInNewWorkbook = 1
         Set Ws(0) = Workbooks.Add.Worksheets(1)
        .SheetsInNewWorkbook = L
         P = .PathSeparator
    With Workbooks.Open(V)
        If Evaluate("ISREF('" & D & "'!A1)") And Evaluate("ISREF('" & S & "'!A1)") Then
             Set Ws(1) = .Worksheets(S):  Set Ws(2) = .Worksheets(D)
                 Ws(1).[A1].Copy Ws(0).[A1]:  Ws(2).[A1:C1].Copy Ws(0).[B1]
                 Ws(1).UsedRange.Columns(1).AdvancedFilter xlFilterCopy, , Ws(1).[E1], True
                 P = .Path & P
        For Each V In Ws(1).Range("E2", Ws(1).[E1].End(xlDown)).Value2
                 Application.StatusBar = "        " & V
                 Ws(1).[E2].Value2 = V
                 Ws(1).[A1].CurrentRegion.AdvancedFilter xlFilterCopy, Ws(1).[E1:E2], Ws(1).[H1:I1]
                 Ws(2).[E2].Formula = "=ISNUMBER(MATCH(A2," & _
                      Ws(1).Range("I2", Ws(1).[I1].End(xlDown)).Address(External:=True) & ",0))"
                 Ws(2).[A1].CurrentRegion.AdvancedFilter xlFilterCopy, Ws(2).[E1:E2], Ws(0).[B1:D1]
            With Ws(0).UsedRange
                .Range("A2:A" & .Rows.Count).Value2 = V
                .Columns.AutoFit
                .Parent.Parent.SaveAs P & V, xlOpenXMLWorkbook
                .Columns(1).Offset(1).Clear
            End With
        Next
           .Close False
        Else
            V = "That's very not the expected source workbook"
        End If
    End With
        Ws(0).Parent.Close False
       .DisplayAlerts = True:      .ScreenUpdating = True:      .StatusBar = False
    End With
        Erase Ws
        If V > "" Then MsgBox V, vbExclamation, "File error"
End Sub 


► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » !

This is exactly what i needed! Follow up question.

How would the code be adjusted if the range on the summary tab extended to BX and the range on the data tab extended to column DX?

You just need to update each range used in the procedure according to your brand new layout …

I revised the ranges in the code, but it doesnt seem to working properly. The last column on my data tab is BH. Where am i messing up?

Sub Demo1()
Const D = "Data", S = "Summary"
Dim V, L&, P$, Ws(2) As Worksheet
With Application
V = .GetOpenFilename("Excel files (*.xlsx), *.xlsx"): If V = False Then Exit Sub
.DisplayAlerts = False: .ScreenUpdating = False
L = .SheetsInNewWorkbook: .SheetsInNewWorkbook = 1
Set Ws(0) = Workbooks.Add.Worksheets(1)
.SheetsInNewWorkbook = L
P = .PathSeparator
With Workbooks.Open(V)
If Evaluate("ISREF('" & D & "'!A1)") And Evaluate("ISREF('" & S & "'!A1)") Then
Set Ws(1) = .Worksheets(S): Set Ws(2) = .Worksheets(D)
Ws(1).[A1].Copy Ws(0).[A1]: Ws(2).[A1:BH1].Copy Ws(0).[B1]
Ws(1).UsedRange.Columns(1).AdvancedFilter xlFilterCopy, , Ws(1).[BJ1], True
P = .Path & P
For Each V In Ws(1).Range("BJ2", Ws(1).[BJ1].End(xlDown)).Value2
Application.StatusBar = " " & V
Ws(1).[BJ2].Value2 = V
Ws(1).[A1].CurrentRegion.AdvancedFilter xlFilterCopy, Ws(1).[BJ1:BJ1], Ws(1).[BM1:BN1]
Ws(2).[BJ2].Formula = "=ISNUMBER(MATCH(A2," & _
Ws(1).Range("BN2", Ws(1).[BN1].End(xlDown)).Address(External:=True) & ",0))"
Ws(2).[A1].CurrentRegion.AdvancedFilter xlFilterCopy, Ws(2).[BJ1:BJ2], Ws(0).[B1:BI1]
With Ws(0).UsedRange
.Range("A2:A" & .Rows.Count).Value2 = V
.Columns.AutoFit
.Parent.Parent.SaveAs P & V, xlOpenXMLWorkbook
.Columns(1).Offset(1).Clear
End With
Next
.Close False
Else
V = "That's very not the expected source workbook"
End If
End With
Ws(0).Parent.Close False
.DisplayAlerts = True: .ScreenUpdating = True: .StatusBar = False
End With
Erase Ws
If V > "" Then MsgBox V, vbExclamation, "File error"
End Sub