Sub TST()
Dim shTmp As Worksheet
Set shTmp = Worksheets("TMP")
Dim shSrc As Worksheet
Set shSrc = Worksheets("SRC")
'
Call CsvRead(shTmp)
Dim buf As String
Dim wb As Workbook
Const Target As String = "C:\Users\Forza1063\Desktop\VBA\TGTBook1.xlsx"
''ファイルの存在チェック
buf = Dir(Target)
If buf = "" Then
MsgBox Target & vbCrLf & "は存在しません", vbExclamation
Exit Sub
End If
''同名ブックのチェック
For Each wb In Workbooks
If wb.Name = buf Then
MsgBox buf & vbCrLf & "はすでに開いています", vbExclamation
Exit Sub
End If
Next wb
''ここでブックを開く
Workbooks.Open Target
'******************************************************************************
Call Edit(shSrc, shTmp)
End Sub
Sub Edit(shSrc, shTmp)
shSrc.Activate
j = 2
'書式コピー
Range("B3:D5").Select
Selection.Copy
Workbooks("TGTBook1.xlsx").Activate
Dim shTgt As Worksheet
Set shTgt = Worksheets("Sheet1")
shTgt.Activate
Range("B3:D5").Select
ActiveSheet.Paste
shTmp.Activate
j = 1
K = 4
Do Until shTmp.Cells(j, 1).Value <> "1"
For i = 2 To 4
shTgt.Cells(K, i).Value = shTmp.Cells(j, i).Value
'MsgBox shTmp.Cells(j, i).Value
Next
j = j + 1
K = K + 1
Loop
'******************************************************************************
shSrc.Activate
Range("B6:D8").Select
Selection.Copy
shTgt.Activate
Range("B6:D8").Select
ActiveSheet.Paste
shTmp.Activate
K = K + 1
Do Until shTmp.Cells(j, 1).Value <> "2"
For i = 2 To 4
shTgt.Cells(K, i).Value = shTmp.Cells(j, i).Value
'MsgBox shTmp.Cells(j, i).Value
Next
j = j + 1
K = K + 1
Loop
End Sub
Sub CsvRead(shTmp)
shTmp.Activate
shTmp.ClearArrows
Cells.Select
Selection.ClearContents
Dim CsvFname As String
CsvFname = "TEXT;C:\Users\Forza1063\Desktop\VBA\csv.txt"
'
With ActiveSheet.QueryTables.Add(Connection:=CsvFname, Destination:=Range("TMP!$A$1"))
.Name = "csv"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 932
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
