| |
▼sakura さん：
こんな感じでどうでしょう？
（TrailingMinusNumbers:=Trueは自分が97環境でデバックしたのでコメントアウトさせてもらいました。）
Sub Sample()
Dim buf2 As String
ChDir "C:\"
buf1 = Application.GetOpenFilename("*.txt,*.txt")
If buf1 = "False" Then Exit Sub
Workbooks.OpenText FileName:=buf1, _
Origin:=xlWindows, _
StartRow:=1, _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=False, _
Comma:=True, _
Space:=False, _
Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1), _
Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1))
' TrailingMinusNumbers:=True
Set ObjSht1 = ActiveWorkbook.ActiveSheet
ChDir "C:\"
buf2 = Application.GetOpenFilename("*.xls,*.xls")
If buf2 = "False" Then Exit Sub
Workbooks.Open buf2
Set ObjBook1 = ActiveWorkbook
For Each Cel In ObjSht1.Range(ObjSht1.Cells(1, 1), ObjSht1.Cells(65000, 1).End(xlUp))
If Trim(Cel.Value) = "野菜" Then
Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))
Do Until Cel2 Is Nothing
Cel.EntireRow.Copy Cel2.EntireRow
Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
Loop
ElseIf Trim(Cel.Value) = "果物" Then
Set Cel2 = ObjBook1.Sheets("果物").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))
Do Until Cel2 Is Nothing
Cel.EntireRow.Copy Cel2.EntireRow
Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
Loop
End If
Set Cel2 = Nothing
Next
ObjBook1.Close True
Set ObjBook1 = Nothing
ObjSht1.Application.ActiveWorkbook.Close False
Set ObjSht1 = Nothing
End Sub
|
|
kazu
- 05/3/22(火) 18:57 -
