Unquie Col Matchに関連するセルのコピーとローカルドライブへの保存

Question

私のワークブックInventoryでは、4つのワークシートがあります。その結果、[Source]タブの[Target]タブの[Target]タブにコピーされます。 [管理者一覧]タブをクリックして、管理者名付きのExcelファイルをデスクトップに保存し、[管理者一覧]タブのすべての名前が完了するまで同様に続行します。 Col Aには、List of Adminsタブの一意の名前のリストがあります。

それぞれの最終的なExcelファイルは、2つのタブの[ターゲットと命令]のみで保存されます。残りのタブは保存する前に削除する必要があります。

年間1000人以上の管理者のための膨大なレコードラインがあり、それらを自動化することが唯一の解決策であったので、私はこれをしたいと思います。

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