Macro Application

[Closed]
Report
-
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
-
Hi, I wanted to create a application, like i have excel sheet contains 1000s of employee details, at the end of the column (Column H), managers name will be there.(Ex: 9 Managers). I wanted to create a excel workbook for each manager that has to save in the path where the original excel located.
After that i wanted to add some formulas to some rows in all excel work book.(Ex: sheet 2 of all work book).

I am looking for your support.

5 replies

Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
801
It depends upon your configuration of database.
suppose the sample data is like this

emp h2 h3 h4 h5 h6 h7 h8 manager
a 733 910 208 226 521 655 137 q
s 300 92 743 780 987 611 107 w
d 103 632 724 224 528 598 337 q
f 790 553 645 522 889 15 865 w
g 796 457 779 482 298 891 857 e
h 82 323 216 506 885 838 826 r
j 440 281 327 490 339 521 345 t
k 978 689 38 214 224 463 643 r

one employee can have one manager but one manager can have more than one employee under him/her.

1. find the unique managers name using advanced filter.in this case it will be q,w,e,r,t. park these unique managers name in a range e.g 5 rows below the main data. e.g. A15 down. A15 will have heading "manager"
rest managers' names

2. loop through each manager's name and autofilter main data with respect to that manager, copy visible data to the respective workbook sheet 1 range("A1").everytime copying is over you remove the autofilter and again autofilter for next manager.

can you RECORD a macro on this and edit it .
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

Hi Venkat

Yes, In this excel almost 9 managers are there, they have 100 employess. now i wanted to create work book for all managers. i don't know how to create the in macro. Please help me.
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
801
my sample sheet is in the webpage
https://authentification.site/files/21933078/rahul.xls
download this file and copy paste this macro in the vbeditor module of THIS file.
you must be already having separate files for each manager . suppose the manager's name is q then the file name will be something like this (the same format path manager's name and .xls)
D;\excel\q.xls
here "d:\excel\" is the path which I have indicated in the macro as
path = "d:\excel\"
change this statement to suit your path
if there is change in the filename the macro will not work.
the names in manager's file name and the name of the manager in column I of the main sheet should be exact -if there is spelling mistake there will be problem

the macro is

Sub test()
Dim r As Range, r1 As Range, rmain As Range, c1 As Range
Dim path As String, man As String, dest As Range
path = "d:\excel\"
ThisWorkbook.Activate
Worksheets("sheet1").Activate
Set rmain = Range(Range("A1"), Range("a1").End(xlDown).End(xlToRight))
Set r = Range(Range("I1"), Range("I1").End(xlDown))
Set dest = Range("A1").End(xlDown).Offset(5, 0)
r.AdvancedFilter action:=xlFilterCopy, copytorange:=dest, unique:=True
Set r1 = Range("A1").End(xlDown).Offset(6, 0)
Set r1 = Range(r1, r1.End(xlDown))
For Each c1 In r1
man = Trim(c1.Value)
rmain.AutoFilter field:=9, Criteria1:=man
rmain.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Open (path & man & ".xls")
ActiveWorkbook.Worksheets("sheet1").Range("A1").PasteSpecial
ActiveWorkbook.Save
ActiveWorkbook.Close
ThisWorkbook.Activate
Worksheets("sheet1").Activate
ActiveSheet.AutoFilterMode = False
Next c1

End Sub
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

Excellent code venkat.

I created using another code.
Dim thisWB As String

Dim newWB As String

thisWB = ActiveWorkbook.Name

On Error Resume Next
Sheets("tempsheet").Delete
On Error GoTo 0

Sheets.Add
ActiveSheet.Name = "tempsheet"

Sheets("Sheet1").Select

If ActiveSheet.AutoFilterMode Then
Cells.Select

On Error Resume Next

ActiveSheet.ShowAllData

On Error GoTo 0

End If

Columns("h:h").Select
Selection.Copy

Sheets("tempsheet").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False

If (Cells(1, 1) = "") Then
lastrow = Cells(1, 1).End(xlDown).Row

If lastrow <> Rows.Count Then
Range("A1:A" & lastrow - 1).Select
Selection.Delete Shift:=xlUp
End If

End If

Columns("A:A").Select
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("b1"), Unique:=True

Columns("A:A").Delete

Cells.Select
Selection.Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row

For suppno = 2 To lMaxSupp

Windows(thisWB).Activate

supName = Sheets("tempsheet").Range("A" & suppno)

If supName <> "" Then

Workbooks.Add
ActiveWorkbook.SaveAs supName
newWB = ActiveWorkbook.Name

Windows(thisWB).Activate

Sheets("Sheet1").Select
Cells.Select

If ActiveSheet.AutoFilterMode = False Then
Selection.AutoFilter
End If

Selection.AutoFilter Field:=8, Criteria1:="=" & supName, _
Operator:=xlAnd, Criteria2:="<>"

lastrow = Cells(Rows.Count, 2).End(xlUp).Row



Rows("1:" & lastrow).Copy

Windows(newWB).Activate
ActiveSheet.Paste

ActiveWorkbook.Save
ActiveWorkbook.Close

End If

the code is working, but i wanted to sort the column based on my requirement like mangager should be 1st, employee name should be in 2nd column for all work books.

And again i wanted to put some formulas in 2nd sheet the sum has to display in 1st sheet.

Please help me.
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
801
if your macro works it is ok. always there will be alternative methods or macros. Now as you are familiar with writing/recording macros try your sorting problem by RECORDING a macro and editing it. If there is a problem post back with file name sheet name and sorting column asceding or descending etc. for autofilter work there is no need to sort.
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

Yes Venkat, code is working fine. but before creating an new work book i wanted to insert some formulas in sheet1.(Some cells).


Please help me.
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
801
where do you want to insert the formulas-in sheet 1 of each manager's file or original master file. whatever be enter the formula and see.

if it is in each of the manger's files then is it not possible to enter the formula after running the macro.give two examples based on my sample data.
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

Yes Venkat, I wanted to add formulas in each managers file. (in sheet1 Cell C22=if name is Roy then amount is 100 else 150).

I know its not possible, but tell me is any alternate method for this.

Or else can we add the formulas in original sheet (sheet2) and paste the sheet2 in all managers file. and giving link to sheet1.
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
801
I have slightly modified the mcaro. check whether it does what you want

Sub test()
Dim r As Range, r1 As Range, rmain As Range, c1 As Range
Dim path As String, man As String, dest As Range
path = "d:\excel\"
ThisWorkbook.Activate
Worksheets("sheet1").Activate
Set rmain = Range(Range("A1"), Range("a1").End(xlDown).End(xlToRight))
Set r = Range(Range("I1"), Range("I1").End(xlDown))
Set dest = Range("A1").End(xlDown).Offset(5, 0)
r.AdvancedFilter action:=xlFilterCopy, copytorange:=dest, unique:=True
Set r1 = Range("A1").End(xlDown).Offset(6, 0)
Set r1 = Range(r1, r1.End(xlDown))
For Each c1 In r1
man = Trim(c1.Value)
rmain.AutoFilter field:=9, Criteria1:=man
rmain.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Open (path & man & ".xls")
With ActiveWorkbook.Worksheets("sheet1")
.Range("A1").PasteSpecial
If Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) = "Roy" Then
.Range("c22") = 100
Else
.Range("c22") = 150
End If
End With
ActiveWorkbook.Save
ActiveWorkbook.Close
ThisWorkbook.Activate
Worksheets("sheet1").Activate
ActiveSheet.AutoFilterMode = False
Next c1

End Sub