• Ask a Question
150
Insert Image Size must be less than < 5MB.
    Ask a Question
    Cancel
    150
    More answer You can create 5 answer(s).
      Ask a Poll
      Cancel
      Expert

      Need help to modify the macro.

      Hi everyone,

      In my team at work, we have 6 people and our team leader allocates work. He inputs the details in a worksheet named zMaster.xlsm with the following headings.

      Item Qty Price Total Invoice Team Mbr Date Alloc
      A1 22 $44.21 $972.62 AD14256 Raghu  
      A2 10 $210.44 $2104.40 AD14257 Ravi  
      A3 22 $10.00 $220.00 AD14258 Raghu  

       

      There could be hundreds of lines in the morning he clicks on a button and the following sheets are created with in the same folder named Raghu.xlsx

      Item Qty Price Total Invoice Team Mbr Date Alloc
      A1 22 $44.21 $972.62 AD14256 Raghu  
      A3 22 $10.00 $220.00 AD14258 Raghu  

      And this one is named Ravi.xlsx

      Item Qty Price Total Invoice Team Mbr Date Alloc
      A2 10 $210.44 $2104.40 AD14257 Ravi  

      I have found the code to do this.

      I need slight modification to make it work for me.

      The code should also input the date in the “Date Alloc” field.

      The code if run again overwrites the file name if it exists. I don’t the files to be over written. I want the new work to be added to the next blank line in each team member’s file. The code I found is as from the web pages

      https://stackoverflow.com/questions/46368771/how-to-create-a-new-workbook-for-each-unique-value-in-a-column?rq=1

      Sub ExportByName()
      Dim unique(1000) As String
      Dim wb(1000) As Workbook
      Dim ws As Worksheet
      Dim x As Long, y As Long, ct As Long, uCol As Long
      On Error GoTo ErrHandler
      Application.ScreenUpdating = False
      Application.Calculation = xlCalculationManual
      Set ws = ActiveWorkbook.Sheets("Sheet1") 'Your main worksheet
      'Column F
      uCol = 6
      ct = 0
      'get a unique list of users
      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
      'loop through the unique list
      For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row - 1
      If unique(x) <> "" Then
      'add workbook
      Set wb(x) = Workbooks.Add
      'copy header row
      ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)
      'loop to find matching items in ws and copy over
      For y = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
      If ws.Cells(y, uCol) = unique(x) Then
      'copy full formula over
      '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)
      'to copy and paste values
      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 (xlPasteValues)
      End If
      Next y
      'autofit
      wb(x).Sheets(1).Columns.AutoFit
      'save when done
      wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x)
      'wb(x).Close SaveChanges:=True
      Else
      'once reaching blank parts of the array, quit loop
      Exit For
      End If
      Next x
      Application.ScreenUpdating = True
      Application.Calculation = xlCalculationAutomatic
      ErrHandler:
      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
      

      Thank you to all

      Regards

      Raghu

      Asked by raghuprabhu on March 10, 2018 in VBA.
      6 Answers
      Expert

      Hi Raghu,  Please try changing the following lines in the code.

      Line 5 – – Add:  gCol As Long

      From: Dim x As Long, y As Long, ct As Long, uCol As Long

      To:   Dim x As Long, y As Long, ct As Long, uCol As Long, gCol As Long

      .

      New line 11 add:  gCol = 7 – (Note uCol=6 will now be line 12)

      .

      Line 26- – Change uCol to gCol

      From:  ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)

      To:   ws.Range(ws.Cells(1, 1), ws.Cells(1, gCol)).Copy wb(x).Sheets(1).Cells(1, 1)

      .

      Line 33 – – Change uCol to gCol

      From:  ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy

      To:    ws.Range(ws.Cells(y, 1), ws.Cells(y, gCol)).Copy

      Answered by Hyside2 on March 12, 2018..
      Expert

      Thanks Hyside2, Will try out and get back to you.

       

      Regards

      Raghu

      Answered by raghuprabhu on March 12, 2018..
      Expert

      Hi Hyside2,

      Want to change the code, as follows

       

      If unique file exists open then

      Go back to master, select all records for the unique member

      Copy

      Go back to the unique file

      Go to the last line and paste

      Save and close

      Else

      Create unique fille

      Go back to master, select all records for the unique member

      Copy

      Go back to the unique file

      Go to the last line and paste

      Save and close

      End if

       

      Thank you

       

      Regards

      Raghu

      Answered by raghuprabhu on March 16, 2018..
      Expert

      Hi Hyside2,

       

      Basically edit this for loop.

       

      If unique(x) <> “” Then
      ‘add workbook
      Set wb(x) = Workbooks.Add

      ‘copy header row
      ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)

      ‘loop to find matching items in ws and copy over
      For y = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
      If ws.Cells(y, uCol) = unique(x) Then
      ‘copy full formula over
      ‘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)
      ‘to copy and paste values
      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 (xlPasteValues)
      End If
      Next y
      ‘autofit
      wb(x).Sheets(1).Columns.AutoFit
      ‘save when done
      wb(x).SaveAs ThisWorkbook.Path & “\” & unique(x)
      wb(x).Close SaveChanges:=True
      Else
      ‘once reaching blank parts of the array, quit loop
      ‘if new lines are in the master workbook, copy and paste them at the bottom of the unique work sheets             <<<<<<   Write this code
      Exit For
      End If

       

      Thanks

      Raghu

      Answered by raghuprabhu on March 17, 2018..
      • Hello Raghu, This code is complex for my skill level. However I am working on it and hope to have a solution soon.

        on March 19, 2018.
      Cancel
      Add comment
      Expert

      Hello Raghu, Here is what I came up with.

      Please change  workbook path ” E:\Excel\Raghu\  ” to the path that you save the workbooks to.

      RE: Need help to modify the macro.

       

      Sub ExportByName()
      Dim unique(1000) As String
      Dim wb(1000) As Workbook
      Dim ws As Worksheet
      Dim x As Long, y As Long, ct As Long, uCol As Long, gCol As Long ' Added gCol As Long to original
      On Error GoTo ErrHandler
      Application.ScreenUpdating = False
      Application.Calculation = xlCalculationManual
      Set ws = ActiveWorkbook.Sheets("Sheet1") 'Your main worksheet
      uCol = 6 'Column F
      gCol = 7 'Column G Added to original(Hyside2)
      ct = 0
      'get a unique list of users
      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
      'loop through the unique list
      For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row - 1
      If unique(x) <> "" Then
      'add workbook
      Set wb(x) = Workbooks.Add
      'copy header row
      ws.Range(ws.Cells(1, 1), ws.Cells(1, gCol)).Copy wb(x).Sheets(1).Cells(1, 1) 'Changed uCol to gCol
      'loop to find matching items in ws and copy over
      For y = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
      If ws.Cells(y, uCol) = unique(x) Then
      'copy full formula over
      '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)
      'to copy and paste values
      ws.Range(ws.Cells(y, 1), ws.Cells(y, gCol)).Copy 'Changed uCol to gCol
      wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial (xlPasteValues)
      End If
      Next y
      'autofit
      wb(x).Sheets(1).Columns.AutoFit
      'save when done
      ' wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x)
      ' Opens sheets that already exist
      If Len(Dir("E:\Excel\Raghu\" & unique(x) & ".xlsx")) > 0 Then ' Hyside2 says change this dir E:\Excel\Raghu\ to your dir
      Rows("1:1").Select
      Selection.ClearContents
      [a2].Select
      ActiveCell.CurrentRegion.Select
      Selection.Copy
      Workbooks.Open Filename:="E:\Excel\Raghu\" & unique(x) & ".xlsx"
      ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
      wb(x).Close Savechanges:=False
      ActiveWorkbook.Save
      Else
      'Save unique sheets only
      wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x)
      End If
      'wb(x).Close SaveChanges:=True
      Else
      'once reaching blank parts of the array, quit loop
      Exit For
      End If
      Next x
      Application.ScreenUpdating = True
      Application.Calculation = xlCalculationAutomatic
      ErrHandler:
      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
      
      Answered by Hyside2 on March 19, 2018..
      • Path must be changed in line 82

        on March 19, 2018.
      Cancel
      Add comment
      Expert

      Hi All and Hyside2,

      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 4 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.

      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
      

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

      I was able to do this thanks mainly to Hyside2 for his guidance and encouragement.

      Regards

      Raghu Prabhu

      Answered by raghuprabhu on April 1, 2018..