Kopieren von Zellen, die für Unquie relevant sind Col Match und Speichern auf lokalem Laufwerk

Question

In meiner Arbeitsmappe Inventar habe ich 4 Arbeitsblätter, und ich möchte die Ergebnisse in der Registerkarte Quelle auf Ziel Registerkarte für den bestimmten Administrator die Spalte 'Name' in übereinstimmen Klicken Sie auf die Registerkarte Liste der Admins, und speichern Sie die Excel-Datei mit dem Admin-Namen auf dem Desktop, und fahren Sie dann fort, bis alle Namen auf der Registerkarte Liste der Administratoren angezeigt werden. Der Col A enthält die Liste der eindeutigen Namen auf der Registerkarte Liste der Admins.

Jede der endgültigen Excel-Datei wird mit nur den 2 Registerkarten Ziel und Anweisungen gespeichert; Der Rest der Tabs muss vor dem Speichern gelöscht werden.

Ich möchte dies tun, da es eine riesige Menge an Rekordlinien für mehr als 1000 Admins das ganze Jahr über gibt, und die Automatisierung war die einzige Lösung.

Answer 1

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