Help needed to modify the following macro

[raghuprabhu]

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

 

[smiler44]

this will find the first blank cell in column A so you could use this if there are no gaps in column A to find the next blank cell/row

Sub Macro1()
Dim lst As String
Dim lr As String
ActiveSheet.Range("a2").Select ' row to start
If ActiveCell.Offset(1, 0) <> "" Then
Selection.End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
lst = ActiveCell.Address ' cell address of first blank cell
lr = Right(lst, Len(lst) - 3) ' just the number of the first blank cell
MsgBox lr
End Sub

or this macro will tell you the last row used

Private Sub CommandButton1_Click()
Dim ExcelLastCell As Object, lRow As Long, lLastDataRow As Long, l As Long
Set ExcelLastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
lLastDataRow = ExcelLastCell.Row
lRow = ExcelLastCell.Row
Do While Application.CountA(ActiveSheet.Rows(lRow)) = 0 And lRow <> 1
lRow = lRow - 1
Loop
lLastDataRow = lRow
Sheets("sheet1").TextBox1.Text = lLastDataRow
End Sub