| |
こんにちは
コード記載のファイルと比較するファイルは同じフォルダにする事
コード記載のファイルにUserFom1を作りそこにコンボボックスを
ひとつ用意して下さい。（複数のシートを選択します。）
下記を標準モジュールに記載
Public Sh As String
Sub Test()
Dim MyFi As Variant, MyPh As String, i As Long
Dim Wb(1) As Workbook, Ch As Boolean, Ws As Worksheet
Dim C As Range, Ma As Variant, Ws1 As Worksheet, NowWb As Workbook
Dim Co As Long
Ch = True: Co = 1
MyPh = ThisWorkbook.Path & "\"
ChDir MyPh
MyFi = Application.GetOpenFilename("Excelファイル (*.xls),*.xls", , , , True)
If VarType(MyFi) = 11 Then Exit Sub
If UBound(MyFi) <> 2 Then Exit Sub
Application.ScreenUpdating = False
Set Wb(0) = Workbooks.Open(MyFi(1))
Set Wb(1) = Workbooks.Open(MyFi(2))
If Wb(0).Sheets.Count > 1 Then
Call Chekc(Wb(0))
ElseIf Wb(1).Sheets.Count > 1 Then
Call Chekc(Wb(1))
Ch = False
End If
Application.ScreenUpdating = True
UserForm1.Show
If Sh = "" Then GoTo End_Len
If Ch Then
Set Ws = Wb(0).Worksheets(Sh)
Set Ws1 = Wb(1).Worksheets(1)
Else
Set Ws = Wb(1).Worksheets(Sh)
Set Ws1 = Wb(0).Worksheets(1)
End If
Application.ScreenUpdating = False
Set NowWb = Workbooks.Add(1)
For Each C In Ws.Range("F1", Ws.Range("F65536").End(xlUp))
Ma = Application.Match(C.Value, Ws1.Columns(6), 0)
If Not IsError(Ma) Then
C.EntireRow.Copy NowWb.Worksheets(1).Cells(Co, 1)
Co = Co + 1
End If
Next C
Application.ScreenUpdating = True
End_Len:
Wb(0).Close False
Wb(1).Close False
Set Ws = Nothing: Set Ws1 = Nothing
Set Wb(0) = Nothing: Set Wb(1) = Nothing
Set NowWb = Nothing
End Sub
Private Sub Chekc(Wb1 As Workbook)
Dim ii As Long
For ii = 1 To Wb1.Sheets.Count
UserForm1.ComboBox1.AddItem Sheets(ii).Name
Next ii
End Sub
下記をUserForm1のモジュールに記載
Private Sub ComboBox1_Change()
If Me.ComboBox1.Value = "" Then
MsgBox "シート名を選択して下さい。"
Else
Sh = Me.ComboBox1.Value
Unload Me
End If
End Sub
流れ：Sub Test()を実行すると「ファイル開く」が出ますので、該当のファイルを２つ選択して「開く」を押す。
UserForm1が表示しますのでコンボボックスでシートを選択（複数あるシートを選択させます）
後は新しいファイルを作りコピーします。
ではお試しを
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
