• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro to create multiple .xlsx file based on a column value

B

bijicha

Member
Experts,

I need to generate separate invoice number.xlsx (column H vlaue.xlsx) file based on the last column invoices. I need the column F to be unmerged and populate with previous cell data, then Column A to G in separate files based on column H.

Please help

Thanks
 

Attachments

  • AE_113_00647_00015.xlsx
    19.4 KB · Views: 22
As with an advanced filter the data is automatically unmerged in the destination …​
​
 
Hi @bijicha
try this code, new files are created in the same folder as the Excel workbook

Code: 
Sub test20230402()
'https://chandoo.org/forum/threads/macro-to-create-multiple-xlsx-file-based-on-a-column-value.52165/
    
Dim rng             As Range, cell As Range, joinedCells As Range
Dim i               As Long, lastRow As Long
Dim targetWorkbook  As Workbook
Dim v As Variant
Dim NewFile         As String
Dim sh              As Worksheet, NewSh As Worksheet
    
Set sh = Sheets("Sheet 1")
sh.Copy After:=Sheets(Sheets.Count)

Set NewSh = Sheets(Sheets.Count)

lastRow = NewSh.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

v = NewSh.Range("A2:H" & lastRow).Value

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

With CreateObject("scripting.dictionary")
    
    For i = 2 To UBound(v)
        If Not .exists(v(i, 8)) Then
            .Add v(i, 8), Nothing
            
            With NewSh
                For Each cell In .UsedRange.Columns("F").Cells
                    If cell.MergeCells Then
                        
                        Set joinedCells = cell.MergeArea
                        cell.MergeCells = False
                        joinedCells.Value = cell.Value
                    End If
                Next cell
                
                .Range("A1").AutoFilter 8, v(i, 8)
                Set rng = .AutoFilter.Range
                Set targetWorkbook = Workbooks.Add
                .UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(Sheets.Count).Range("A1")
                NewFile = v(i, 8) & ".xlsx"
                
                With targetWorkbook
                    '.ActiveSheet.Columns.AutoFit
                    .ActiveSheet.UsedRange.EntireColumn.AutoFit
                    .ActiveSheet.UsedRange.EntireRow.AutoFit
                    
                    .SaveAs ThisWorkbook.Path & "\" & NewFile
                    .Close
                End With
                
            End With
        End If
        
    Next i
End With

NewSh.Range("A1").AutoFilter
Application.DisplayAlerts = False
NewSh.Delete

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub
 
According to the attachment an Excel basics VBA demonstration to paste only to its Sheet1 (Sheet 1) worksheet module :​
Code: 
Sub Demo1()
        Dim R&, Ra As Range
    With Application
       .DisplayAlerts = False
       .ScreenUpdating = False
    With UsedRange.Columns
       .Item(8).AdvancedFilter 2, , [K1], True
    If Application.CountBlank(.Item(6)) Then
       .Item(6).UnMerge
        For Each Ra In .Item(6).SpecialCells(4).Areas:  Ra(0).Copy Ra:  Next
    End If
        Workbooks.Add xlWBATWorksheet
        ActiveWindow.DisplayWorkbookTabs = False
        [A1:G1].Copy
        ActiveSheet.[A1].PasteSpecial 8
    For R = 2 To [K1].CurrentRegion.Rows.Count
       .AutoFilter 8, Cells(R, 11)
       .Item("A:G").Copy ActiveSheet.[A1]
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Cells(R, 11), 51
        ActiveSheet.UsedRange.Clear
    Next
       .AutoFilter 8
    End With
        ActiveWorkbook.Close False
        [K1].CurrentRegion.Clear
       .DisplayAlerts = True
       .ScreenUpdating = True
    End With
End Sub
Do you like it ? So thanks to click on bottom right Like !​
​
 
Hi Keetoowah/Marc , both of your codes working as i required, but i need one more help.

As the data file is generating every day, so i prefer to run the code in a separate xlsm file with a bottom click in the same folder. i mean the Macro file will be always unchanged, only the daily data files replace previous days file.. So i need to run this macro from a separate file.

Keetoowah, can you help the final files with data of columns A to G and to run the code from another file say COOMacro.xlsm

Marc, your code is perfectly generating files Colum A to G, but if you can help this code to be in the module of another file and while button click it will open the daily xlsx file and generate the individual files..
 
Why again such important information is not in the initial post ?‼​
Like I suspected, the reason why my post #2 was 'light', expecting a reaction … Before to go further,​
do you need column F unmerged only in the individual files or first in the source workbook ?​
​
 
Is the daily file in the same folder as the workbook where the VBA procedure should stand ?​
​
 
My revamped Excel basics VBA demonstration to paste only to ThisWorkbook module :​
Code: 
Sub Demo1r()
  Const C = 32
    Dim V, B(1) As Boolean, Ra As Range, Ws As Worksheet, R&
        ChDrive Path:  ChDir Path
    With Application
       .Speech.Speak "Choose a daily invoices Excel workbook", True
       .DisplayAlerts = False
       .ScreenUpdating = False
    Do
        V = .GetOpenFilename("Daily Invoices workbook,*.xlsx"):  If V = False Then Exit Do
    With Workbooks.Open(V, 0).ActiveSheet.UsedRange.Columns
       B(0) = .Cells(1, 8) = "Invoice Number"
    If B(0) Then
       .Item(8).AdvancedFilter 2, , .Cells(1, C), True
     If Application.CountBlank(.Item(6)) Then
        B(1) = True
       .Item(6).UnMerge
        For Each Ra In .Item(6).SpecialCells(4).Areas:  Ra(0).Copy Ra:  Next
     End If
        Set Ws = Workbooks.Add(xlWBATWorksheet).ActiveSheet
        ActiveWindow.DisplayWorkbookTabs = False
       .Range("A1:G1").Copy
        Ws.[A1].PasteSpecial 8
    For R = 2 To .Cells(1, C).End(xlDown).Row
       .AutoFilter 8, .Cells(R, C)
       .Item("A:G").Copy Ws.[A1]
        Ws.UsedRange.Columns(2).AutoFit
        Ws.Parent.SaveAs Path & "\" & .Cells(R, C), 51
        Ws.UsedRange.Clear
    Next
        Application.Speech.Speak "Done!", True
        Ws.Parent.Close False
        Set Ws = Nothing
        If B(1) Then .AutoFilter 8: .Item(C).Clear
    Else
        Application.Speech.Speak "Wrong file!", True, , True
    End If
       .Parent.Parent.Close B(1)
    End With
    Loop Until B(0)
       .DisplayAlerts = True
       .ScreenUpdating = True
    End With
End Sub
You should Like it !​
​
 
Hi Marc,

One question, if i want to add the countries list in the Macro file and the same to VLOOKUP to the Data file column B with two digit of column F, immediately after unmerging column F
 

Attachments

  • Macro.xlsm
    20.6 KB · Views: 5
Why blank rows within this list ?! Shoud be better without …​
​
Anyway my revamped ThisWorkbook Excel basics VBA demonstration revisited to include such VLOOKUP :​
Code: 
Sub Demo1r2d2()
  Const C = 32
    Dim V, S As Boolean, Ra As Range, Ws As Worksheet, R&
        ChDrive Path:  ChDir Path
    With Application
       .Speech.Speak "Choose a daily invoices Excel workbook", True
       .DisplayAlerts = False
       .ScreenUpdating = False
    Do
       V = .GetOpenFilename("Daily Invoices workbook,*.xlsx"):  If V = False Then Exit Do
    With Workbooks.Open(V, 0).ActiveSheet.UsedRange.Columns
       S = .Cells(1, 8) = "Invoice Number"
    If S Then
       .Item(8).AdvancedFilter 2, , .Cells(1, C), True
     If Application.CountBlank(.Item(6)) Then
       .Item(6).UnMerge
        For Each Ra In .Item(6).SpecialCells(4).Areas:  Ra(0).Copy Ra:  Next
     End If
       .Item(6) = Application.IfError(Application.VLookup(.Item(6), Sheet2.UsedRange, 2, False), .Item(6))
       .Item(6).AutoFit
        Set Ws = Workbooks.Add(xlWBATWorksheet).ActiveSheet
        ActiveWindow.DisplayWorkbookTabs = False
       .Range("A1:G1").Copy
        Ws.[A1].PasteSpecial 8
    For R = 2 To .Cells(1, C).End(xlDown).Row
       .AutoFilter 8, .Cells(R, C)
       .Item("A:G").Copy Ws.[A1]
        Ws.UsedRange.Columns(2).AutoFit
        Ws.Parent.SaveAs Path & "\" & .Cells(R, C), 51
        Ws.UsedRange.Clear
    Next
        Application.Speech.Speak "Done!", True
        Ws.Parent.Close False
        Set Ws = Nothing
       .AutoFilter 8
       .Item(C).Clear
    Else
        Application.Speech.Speak "Wrong file!", True, , True
    End If
       .Parent.Parent.Close S
    End With
    Loop Until S
       .DisplayAlerts = True
       .ScreenUpdating = True
    End With
End Sub
You may Like it !​
​
 
You must log in or register to reply here.
Back
Top