Copying Cells Relevant to Unquie Col Match and Save to Local Drive

Shanl

New member
Joined
Apr 14, 2016
Messages
3
Reaction score
0
Points
0
I am new to VBA, and was going back and forth between the available codes trying to create VBA to execute the following, but was not able to get a complete one that get through end to end:
In my workbook Inventory, I have 4 worksheets, and I would like to copy the results in Source tab to Target tab for that particular admin matching the 'Name' col in the List of Admins tab, and then save that excel file with the Admin Name on my desktop and then continue likewise until all the names under the List of Admins tab is done. The Col A has the list of unique names under the List of Admins tab.
Each of he final Excel file will be saved with only the 2 tabs Target and Instructions; the rest of the tabs must be deleted before saving.
I would like to do this since there is a huge volume of record lines for more than 1000s of admins throughout the year, and automating them was the only solution.
Please help.
Appreciate any suggestions to improve time and efficiency.
Thank you.
 
Here is the code that I have put together so far from various searches:

Sub Main()

Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetWorkbook As Workbook
Set targetWorkbook = Application.ActiveWorkbook
filter = "Text files (*.xls),*.xls"
caption = "Please Select an input file "
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
Dim Source As Worksheet
Dim Datafile1 As Worksheet
Set Datafile = customerWorkbook.Worksheets(1)
Set AdminList= customerWorkbook.Worksheets(2)
Set Source = targetWorkbook.Worksheets(1)
Set List_of_Admins = targetWorkbook.Worksheets(3)
Source.Range("A1", "C100000").Value = Datafile.Range("A3", "C100000").Value
List_of_Admins.Range("A1", "D100000").Value = AdminList.Range("A3", "D100000").Value
targetWorkbook.Worksheets(4).Activate
customerWorkbook.Close savechanges:=False
Dim x As Integer
Sheets("List_of_Admins").Select
NumRows = Range("A2", Range("A2").End(xlDown)).Rows.Count
Sheets("List_of_Admins").Select
Range("A2").Select
For x = 1 To NumRows
ActiveCell.Select
Selection.Copy
Sheets("Instructions").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks :=False, Transpose:=False
Dim filterList1 As Variant
filterList1 = Array("Ann", "Sarah", "Kevin", "Naomi", "James")
filterCol1 = 1
lastrowSrc = Sheets("Source").Range("A" & Rows.Count).End(xlUp).Offset(1).Row
lastrowDest = Sheets("Target").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Source").AutoFilterMode = False
Sheets("Source").Range("$A$1:$O" & lastrowSrc).AutoFilter Field:=filterCol1, Criteria1:=filterList1, Operator:=xlFilterValues
Sheets("Source").Range("A2:O" & lastrowSrc).SpecialCells (xlCellTypeVisible).Copy Destination:=Sheets("Target").Cells(lastrowDest + 1, 1)
Dim save_as As Variant
Dim file_name As String
file_name = Sheets("Instructions").Range("C1")
save_as = Application.GetSaveAsFilename(file_name, FileFilter:="Excel Files,*.xlsm,All Files,*.*")
If save_as = False Then Exit Sub
If LCase$(Right$(save_as, 4)) <> ".xls" Then
file_name = save_as & ".xls"
End If
ActiveWorkbook.SaveAs Filename:=save_as
'Next - repeat back to loop
Sheets("List_of_Admins").Select
ActiveCell.Offset(1, 0).Select
Next
Sheets("Instructions").Select
Range("C1").Select
End Sub

Need help getting it right as mentioned above.
 
Back
Top