Go Back   Access World Forums > Apps and Windows > Excel

Thread Tools Rate Thread Display Modes
Old 03-10-2018, 01:16 PM   #1
Newly Registered User
Join Date: Mar 2008
Posts: 152
Thanks: 43
Thanked 6 Times in 6 Posts
raghuprabhu is on a distinguished road
Help needed to modify the following 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

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
        'save when done
        wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x) 
        'wb(x).Close SaveChanges:=True
        'once reaching blank parts of the array, quit loop
        Exit For
    End If
Next x
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
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



raghuprabhu is offline   Reply With Quote

Thread Tools
Display Modes Rate This Thread
Rate This Thread:

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Modify cells macro evanhughes Modules & VBA 2 07-20-2011 12:11 AM
Macro to Modify SQL Query LadyDi Macros 1 04-20-2010 07:13 PM
How do you run a macro to modify a form sandi1970 Macros 3 05-21-2009 11:05 AM
Help needed to modify my OnOpen Filter chrisb1981 Modules & VBA 3 03-16-2007 06:33 AM
Help needed to modify code WebFaktor Forms 5 05-30-2002 02:19 PM

All times are GMT -8. The time now is 01:03 AM.

Microsoft Access Help
Modules & VBA
Theory & Practice
Access FAQs
Code Repository
Sample Databases
Video Tutorials

Sponsored Links

How to advertise

Media Kit

Powered by vBulletin®
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
(c) copyright 2017 Access World