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

[adamshl]

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

[Marc L]

Hi,

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

[adamshl]

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.

[Marc L]

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 ?

[adamshl]

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.

[Marc L]

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 ?

[adamshl]

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

[Marc L]

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 - …

[adamshl]

Yes name and path of the source workbook could change.

[Marc L]

Ok, now any helper can give it a try …

[Marc L]

A VBA starter demonstration :

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 » !

[adamshl]

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?

[Marc L]

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

[adamshl]

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