Go Back   Access World Forums > Apps and Windows > Excel

 
Reply
 
Thread Tools Rate Thread Display Modes
Old 03-10-2018, 01:16 PM   #1
raghuprabhu
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
https://stackoverflow.com/questions/...-a-column?rq=1

Code:
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

raghuprabhu is offline   Reply With Quote
Old 06-26-2018, 10:44 AM   #2
smiler44
Newly Registered User
 
Join Date: Jul 2008
Location: UK
Posts: 575
Thanks: 8
Thanked 9 Times in 8 Posts
smiler44 is on a distinguished road
Re: Help needed to modify the following macro

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
smiler44 is offline   Reply With Quote
Reply

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 03:26 PM.


Microsoft Access Help
General
Tables
Queries
Forms
Reports
Macros
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