16 Comments

1. 

   Prabhas on 20170526062317 at 06:23

   The tool is really nice. one thing i would like to suggest that the out put can be set with ” Autofit Column Width”.

   • 

     John on 20170526074358 at 07:43

     Good suggestion. I’ll try to add that in the next few days.

     • 

       Shabbir on 20170701010731 at 01:07

       What if file name already exists that it’s going to create? Will this help in uniqueness:
       ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), ” YYYY-MM-DD hhmmss”) & “.xlsx”, 51
       (I’m new to VBA)

       • 

         John on 20170701102409 at 10:24

         Yes, a time stamp on the file name is an excellent idea and will prevent duplicates. My solution will currently overwrite any file that already exists.

     • 

       Lou-Ellen on 20180510221646 at 22:16

       Hi John – what an awesome tool! Thanks so much for sharing. Do you have the VBA script of how to make the output set to Autofit Column Width? Thanks mate!

2. 

   Raghu Prabhu on 20180331233218 at 23:32

   April 1, 2018 at 12:38 am
   Hi All,

   I have a master file with the following headings

   S No
   Item
   Price
   Qty
   Total
   Distributed
   Task1
   Task2
   Task3
   Task4
   Completed
   Consolidated
   Comments
   Team Member

   The Team leader inputs the data in first 3 columns and selects the name of the team member to be given the task for column 14.

   He then runs the macro ExportByName and new workbooks are created if they already exist then add to the end of the file.

   The team members do the tasks and fill in columns Task1, Task2, Task3, Task4 and then date completed.

   When the team leader runs the following macros

   Sub BringInAllCompletedData()
   Call SortAllFiles
   Call LoopThroughDirectory
   Call UpdateDateInSheet1ColK
   Call UpdateOriginalData
   Call ClearSheet1
   End Sub

   All the work completed is consolidated.

   [code]

   Sub ExportByName()
   Dim unique(1000) As String
   Dim wb(1000) As Workbook
   Dim ws As Worksheet
   Dim x As Long
   Dim y As Long
   Dim ct As Long
   Dim uCol As Long

   On Error GoTo ErrHandler

   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Application.DisplayAlerts = False

   ‘Your main worksheet info.
   Set ws = ActiveWorkbook.Sheets(“OriginalData”)

   Let uCol = 14 ‘Column O

   Dim Strt As Long, Stp As Long: Let Strt = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row + 1: Stp = ws.Cells(ws.Rows.Count, uCol).End

   (xlUp).Row

   Let ws.Range(“F” & Strt & “:F” & Stp & “”).Value = Format(Date, “dd/mmm/yyyy”) ‘ adding the dates to the new rows

   Let ws.Range(“A” & Strt & “:A” & Stp & “”).Value = Application.Evaluate(“=row(” & Strt & “:” & Stp & “)-1”) ‘ adding the S.no. to

   the new rows

   ct = 0

   For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
   If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
   unique(ct) = ActiveSheet.Cells(x, uCol).Text
   ct = ct + 1
   End If
   Next x

   For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row – 1
   If unique(x) “” Then
   If Dir(ThisWorkbook.Path & “\” & unique(x) & “.xlsx”, vbNormal) = “” Then ‘If unique file does not exist

   Workbooks.Add: Set wb(x) = ActiveWorkbook
   ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)
   Else
   Workbooks.Open filename:=ThisWorkbook.Path & “\” & unique(x) & “.xlsx”
   Set wb(x) = ActiveWorkbook
   End If

   For y = Strt To Stp
   If ws.Cells(y, uCol) = unique(x) Then
   ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
   wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial

   Paste:=xlPasteValuesAndNumberFormats
   End If
   Next y
   ‘autofit
   wb(x).Sheets(1).Columns.AutoFit
   wb(x).SaveAs ThisWorkbook.Path & “\” & unique(x) & “.xlsx”, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
   wb(x).Close SaveChanges:=True
   Else
   ‘Quit loop
   Exit For
   End If
   Next x

   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic

   ErrHandler:
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic

   End Sub

   Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
   CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
   End Function

   Sub BringInAllCompletedData()
   Call SortAllFiles
   Call LoopThroughDirectory
   Call UpdateDateInSheet1ColK
   Call UpdateOriginalData
   Call ClearSheet1
   End Sub

   ‘https://www.mrexcel.com/forum/excel-questions/471802-vba-open-file-run-code-close-save-open-next-file.html
   Sub SortAllFiles()
   Dim folderPath As String
   Dim filename As String
   Dim wb As Workbook

   Application.DisplayAlerts = False

   folderPath = ActiveWorkbook.Path & “\” ‘change to suit
   If Right(folderPath, 1) “\” Then folderPath = folderPath + “\”
   filename = Dir(folderPath & “*.xlsx”)
   Do While filename “”
   Application.ScreenUpdating = False
   Set wb = Workbooks.Open(folderPath & filename)
   ‘Call a subroutine here to operate on the just-opened workbook
   If filename = “zmaster.xlsm” Then
   Exit Sub
   Else
   Call SortSheet1InAllFiles
   End If
   filename = Dir
   Loop
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   End Sub

   Sub SortSheet1InAllFiles()
   Dim MyFile As String
   Dim eRow As Long
   Dim RowsConsolidated As Long
   Dim LastRow As Long
   Dim i As Long

   eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

   Cells.Select
   ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Clear
   ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Add Key:=Range(“K2:K” & eRow) _
   , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   With ActiveWorkbook.Worksheets(“Sheet1”).Sort
   .SetRange Range(“A1:N” & eRow)
   .Header = xlYes
   .MatchCase = False
   .Orientation = xlTopToBottom
   .SortMethod = xlPinYin
   .Apply
   End With
   ActiveWorkbook.Save
   Range(“A1”).Select
   ActiveWorkbook.Close

   End Sub

   ‘http://www.exceltrainingvideos.com/transfer-data-multiple-workbooks-master-workbook-automatically/

   Sub LoopThroughDirectory()
   Dim MyFile As String
   Dim eRow As Long
   Dim LRL As Long
   Dim LRK As Long
   Dim i As Long

   Dim FilePath As String
   FilePath = ActiveWorkbook.Path & “\”

   Application.DisplayAlerts = False
   Application.ScreenUpdating = False
   Sheets(“Sheet1”).Activate
   MyFile = Dir(FilePath)
   Do While Len(MyFile) > 0
   If MyFile = “zmaster.xlsm” Then
   Exit Sub
   End If

   Workbooks.Open (FilePath & MyFile)
   LRK = Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).Row ‘Column L
   LRL = Cells(Rows.Count, 12).End(xlUp).Offset(1, 0).Row ‘Column K

   For i = LRL To LRK
   Range(“A” & LRL & ” : ” & “K” & LRK).Copy
   Next
   ActiveWorkbook.Close

   eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
   ActiveSheet.Paste Destination:=Worksheets(“Sheet1”).Range(Cells(eRow, 1), Cells(eRow, 11))

   If MyFile = “zmaster.xlsm” Then
   Exit Sub
   End If

   Workbooks.Open (FilePath & MyFile)
   For i = LRL To LRK – 1
   If Range(“L” & i).Value = “” Then
   Range(“L” & i).Value = Date
   Columns(“L:L”).NumberFormat = “[$-C09]dd-mmm-yy;@”
   End If
   Next
   Range(“A1”).Select
   ActiveWorkbook.Save
   ActiveWorkbook.Close

   MyFile = Dir
   ActiveWorkbook.Save
   Loop

   Columns(“A:D”).Select
   ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Clear
   ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Add Key:=Range(“A2:A” & eRow) _
   , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   With ActiveWorkbook.Worksheets(“Sheet1”).Sort
   .SetRange Range(“A1:D” & eRow)
   .Header = xlYes
   .MatchCase = False
   .Orientation = xlTopToBottom
   .SortMethod = xlPinYin
   .Apply
   End With

   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   End Sub

   Sub UpdateDateInSheet1ColK()
   Dim eRow As Long
   Dim i As Long

   Sheets(“Sheet1”).Activate
   eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
   For i = 2 To eRow
   If Range(“K” & i) “” Then
   Range(“L” & i).Value = Format(Date, “dd/mmm/yyyy”)
   End If
   Next
   End Sub

   ‘https://www.youtube.com/watch?v=AzhQ5KiNybk
   Sub UpdateOriginalData()
   Dim i As Integer
   Dim j As Integer
   Dim LastRow1 As Integer
   Dim LastRow2 As Integer
   Dim SNo As Double

   LastRow1 = Sheets(“Sheet1”).Range(“A” & Rows.Count).End(xlUp).Row
   LastRow2 = Sheets(“OriginalData”).Range(“A” & Rows.Count).End(xlUp).Row

   For i = 2 To LastRow1
   SNo = Sheets(“Sheet1”).Cells(i, “A”).Value
   Sheets(“OriginalData”).Activate
   For j = 2 To LastRow2
   If Sheets(“OriginalData”).Cells(j, “A”).Value = SNo Then
   Sheets(“Sheet1”).Activate
   Sheets(“Sheet1”).Range(Cells(i, “G”), Cells(i, “L”)).Copy
   Sheets(“OriginalData”).Activate
   Sheets(“OriginalData”).Range(Cells(j, “G”), Cells(j, “L”)).Select
   ActiveSheet.Paste
   End If
   Next j
   Application.CutCopyMode = False
   Next i
   Sheets(“OriginalData”).Activate
   Cells.Select
   ActiveWorkbook.Save
   Selection.Columns.AutoFit
   Range(“A1”).Select

   End Sub

   Sub ClearSheet1()
   Dim eRow As Long

   Sheets(“Sheet1”).Activate
   eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

   Range(“A2:O” & eRow).Select
   Selection.ClearContents
   Selection.Columns.AutoFit
   Range(“A1”).Select
   ActiveWorkbook.Save
   End Sub
   [/code]

   This is a complete project and I use it at work.

   I am able to do this thanks mainly to guru Dinesh Kumar Takyar.

   Regards

   Raghu Prabhu

3. 

   Phillip hardcastle on 20180613193459 at 19:34

   Hi John,

   I am a novice to Excel VBA and need a little help from you on your code. I need to do exactly what you are describing. I know enough to understand most of it, but in it you reference the following:

   ColumnHeadingInt = WorksheetFunction.Match(Range(“ExportCriteria”).Value, Range(“wks[#Headers]”), 0)
   ColumnHeadingStr = “Distribution_Template[[#All],[” & Range(“ExportCriteria”).Value & “]]”

   The code is giving me a Method ‘Range’ of object’_Worksheet’ failed run-time error (1004). It’s probably because I don’t understand what “ExportCriteria” and “Data[#Headers]” means in the code. They are not defined. Can you explain them?

   • 

     John on 20180627180604 at 18:06

     ExportCriteria is a named range in the spreadsheet template. You can use the name box in Excel to navigate to it and confirm it exists (possibly you accidentally deleted it.

     Data[#Headers] is a table reference. There’s a table named Data and we are referencing the column headings part of the table.

4. 

   Bianca on 20190220115708 at 11:57

   Hi John,

   This is such an amazing template! However, I wanted to know if there was a way to copy and paste as a table instead of values? I haven’t been trying to manipulate the code but haven’t been able to figure it out.

5. 

   Elaine on 20190314134247 at 13:42

   Hi, I can’t download the Example file 😦

   • 

     John on 20190314142325 at 14:23

     I just tested it out. Works fine. Click on the orange button then click on the download icon in the upper right.

6. 

   Andrea on 20190513183949 at 18:39

   Hi John, thank you so much for this template! it works great!!
   How would you recommend me to edit the code to instead of selecting all the filtered rows, it would only select the first 25 (additional to the header)?

   • 

     John on 20190522151030 at 15:10

     Based on the way this code works, there isn’t a way to modify it to do that. Excel has no option to filter on the first N items.

     If you added a column to your data that was an index for each unique item in that field, you could add a criteria filter on the index >= 25.

     ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)

     You would need to modify the above line of code accordingly with a Criteria2. Best of luck!

7. 

   Krishna on 20200110081716 at 08:17

   The Export criteria column I used should not be present in the files created by Macro. Can you please help me with that?

8. 

   Jeff C on 20200121160322 at 16:03

   This solved my challenge – now if they would only give me a raise, lol. Thanks, John!

9. 

   William Smith on 20200202155736 at 15:57

   Hi John, I left an earlier message about adding code that will copy existing data validation(s) from the source worksheet (“data”) to the new workbook(s). I don’t recall if I also commented on the need to copy two supporting worksheets from the source workbook. I know there are many examples of copying worksheets so the trick will be to include the needed code within your macro. I’m assuming the correction section would be:

   ‘Loop through our array of unique field values, copy paste into new workbooks and save
   For ArrayItem = 1 To UBound(ArrayOfUniqueValues)
   ws.ListObjects(“Data”).Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
   ws.Range(“Data[#All]”).SpecialCells(xlCellTypeVisible).Copy
   Workbooks.Add
   Range(“A1″).PasteSpecial xlPasteAll
   ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & Format(Now(), ” YYYY-MM-DD hhmmss”) & “.xlsx”, 51
   ActiveWorkbook.Close False
   ws.ListObjects(“Data”).Range.AutoFilter Field:=ColumnHeadingInt
   Next ArrayItem

   I would also need to set ws = Sheets(“Data”) to include the additional sheets therefore:

   set ws = Sheets(“Data”,”Lists”,”FX”)

   If i’m reading your code correctly, I don’t think including the additional worksheets will interfere with how your code executes. I just need to add the code to copy the additional worksheets.