Macro to create create files

reinhardlanger

New Member
Joined
Oct 25, 2007
Messages
21
Dear All,
its been a while since I posted here, but I am totally stuck with an excel and need to write some code, which I am not very good at.

I have a table with data. Table is from column A to column O.

I would like to filter all data by column F and then copy that data and create individual files (with the name of the filtered data from column F appearing in the file name. Naming of the files should be "YOUR DATA_ name of filtered column F".

If someone could help me with a code to do this it would really help me a lot.

Best,
Reinhard
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
What is the filter criteria in column F? It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 
Upvote 0
OK. so I rearranged the table a bit. As you can see in the screenshot, data is in columns A to L.
I would like to filter for column B "Division". There are 50 different divisions in the file. So in the end I would like to get a duplication of the current tab/file 50x, however each of them only displaying one division type. So the sample table below would result in 2 tables, one for CAP and one for WEL. If there is a way to keep rows 1-9 as a header of each file that would be amazing.

tester.xlsx
ABCDEFGHIJKL
1
2Employees working in Headquarter Divisions and Regional Bureaus
3As at 18 February 2021
4Please note the content of this report is confidential. Please do not share with anyone without the written consent of HRMOI
5* Data comes from an off-cycle extraction, not all actions may have been processed in WINGS
6* Excludes African Risk Capacity employees
7* Excludes Staff on Special Status
8
9DepartmentDivision Org unit titleOrg unit codeActual D/S CountryPosition numberPersonnell numberLast NameFirst NameEmployee subgroupType of contractPersonal grade
10WPCAPCAP Comprehensive Action Plan Team50028161Italy221298748856070sdcsderftyjProfessionalLoan - Fixed TermP-1
11WPCAPCAP Comprehensive Action Plan Team50028161Italy22129336380188regetjProfessionalIndefinite ApptmP-4
12WPCAPCAP Comprehensive Action Plan Team50028161Italy221111558837186rgeryukDirectorFixed TermD-1
13WPWELWEL Staff Wellness Division50025035Italy221116398814037hrtkGeneral ServiceFixed TermG-3
14WPWELWEL Staff Wellness Division50025035Italy221116378822857hrtktyuGeneral ServiceFixed TermG-3
15WPWELWEL Staff Wellness Division50025035Italy221116388835308jtytyhGeneral ServiceFixed TermG-3
16WPWELWEL Staff Wellness Division50025035Italy221195118800613jktyhtyGeneral ServiceContinuingG-4
17WPWELWEL Staff Wellness Division50025035Italy221172988850917ktytyhCSLT RegularShort Term MonthlyCST-J
18WPWELWEL Staff Wellness Division50025035Italy22080782232660jtytyhDirectorFixed TermD-1
list modified
Cell Formulas
RangeFormula
B10:B18B10=LEFT(C10,3)
 
Upvote 0
Try this macro. It will save the newly created files in the same folder as the workbook containing the macro. You can change the folder path (in red) to suit you needs.
Rich (BB code):
Sub CreateFiles()
    Application.ScreenUpdating = False
    Dim lRow As Long, srcWB As Workbook, srcWS As Worksheet, v As Variant, dic As Object
    Set srcWB = ThisWorkbook
    Set srcWS = srcWB.Sheets("Sheet1")
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim LastRow As Long
    v = srcWS.Range("B10", srcWS.Range("B" & Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(v, 1)
        If Not dic.Exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
            With srcWS
                .Range("A9").CurrentRegion.AutoFilter 2, v(i, 1)
                fVisRow = .Range("B10:B" & lRow).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
                .Range("A2:L" & lRow).SpecialCells(xlCellTypeVisible).Copy
                Workbooks.Add
                Range("A1").PasteSpecial
                Columns.AutoFit
                With ActiveWorkbook
                    .SaveAs Filename:=srcWB.Path & Application.PathSeparator & "YOUR DATA_" & srcWS.Range("F" & fVisRow) & ".xlsx", FileFormat:=51
                    .Close False
                End With
            End With
        End If
    Next i
    srcWS.Range("A9").AutoFilter
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
I think I am very close, however I am always getting a Subscript out of range error code. Any idea what might cause this?
Try this macro. It will save the newly created files in the same folder as the workbook containing the macro. You can change the folder path (in red) to suit you needs.
Rich (BB code):
Sub CreateFiles()
    Application.ScreenUpdating = False
    Dim lRow As Long, srcWB As Workbook, srcWS As Worksheet, v As Variant, dic As Object
    Set srcWB = ThisWorkbook
    Set srcWS = srcWB.Sheets("Sheet1")
    lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim LastRow As Long
    v = srcWS.Range("B10", srcWS.Range("B" & Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(v, 1)
        If Not dic.Exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
            With srcWS
                .Range("A9").CurrentRegion.AutoFilter 2, v(i, 1)
                fVisRow = .Range("B10:B" & lRow).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
                .Range("A2:L" & lRow).SpecialCells(xlCellTypeVisible).Copy
                Workbooks.Add
                Range("A1").PasteSpecial
                Columns.AutoFit
                With ActiveWorkbook
                    .SaveAs Filename:=srcWB.Path & Application.PathSeparator & "YOUR DATA_" & srcWS.Range("F" & fVisRow) & ".xlsx", FileFormat:=51
                    .Close False
                End With
            End With
        End If
    Next i
    srcWS.Range("A9").AutoFilter
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Which line of code is highlighted when you click "Debug"? Also, to avoid clutter, please click the "Reply" button instead of the "+Quote" button when responding.
 
Upvote 0
It is weirred. The error message does not have the debug button. Maybe the issue is rather me not doing the things in the right way :(
 
Upvote 0

Forum statistics

Threads
1,213,529
Messages
6,114,155
Members
448,554
Latest member
Gleisner2

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
Back
Top