VBA20181112

Sub sss()

Dim rng As Range

Set rng = Range("B1")
'rng.Select


Dim i As Integer
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
i = 20
Set rng = Union(rng, Range("A" & i - 1 & ":C" & i + 1))

rng.BorderAround LineStyle:=xlContinuous
rng.Interior.Color = &HC0C0C0

Set rng = Nothing

'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Set rng = Range("B1")
Set rng = Union(rng, Range("D" & i - 1 & ":G" & i + 1))

rng.BorderAround LineStyle:=xlContinuous
rng.Interior.Color = vbWhite

Set rng = Nothing


'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::


'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
i = 23
Set rng = Range("B1")
Set rng = Union(rng, Range("A" & i - 1 & ":C" & i + 1))

rng.BorderAround LineStyle:=xlContinuous
rng.Interior.Color = &HC0C0C0

Set rng = Nothing

'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Set rng = Range("B1")
Set rng = Union(rng, Range("D" & i - 1 & ":G" & i + 1))

rng.BorderAround LineStyle:=xlContinuous
rng.Interior.Color = vbWhite

Set rng = Nothing


'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
i = 29
Set rng = Range("A" & i - 1 & ":C" & i + 1)

rng.BorderAround LineStyle:=xlContinuous
rng.Interior.Color = &HC0C0C0

Set rng = Nothing

'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Set rng = Range("D" & i - 1 & ":G" & i + 1)

rng.BorderAround LineStyle:=xlContinuous
rng.Interior.Color = vbWhite

Set rng = Nothing


'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
i = 32
Set rng = Range("A" & i - 1 & ":C" & i + 1)

With rng
.BorderAround LineStyle:=xlContinuous
.Borders(xlEdgeTop).LineStyle = xlLineStyleNone
.Interior.Color = &HC0C0C0
End With

Set rng = Nothing

'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Set rng = Range("D" & i - 1 & ":G" & i + 1)

With rng
.BorderAround LineStyle:=xlContinuous
.Borders(xlEdgeTop).LineStyle = xlDash
.Interior.Color = vbWhite
End With

Set rng = Nothing


'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::


Set rng = Range("B1")
'rng.Select

Set rng = Union(rng, Range("E2:F3"))
rng.Select
rng.BorderAround LineStyle:=xlContinuous

rng.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
'rng.Borders.LineStyle = xlLineStyleNone

rng.Borders(xlEdgeBottom).LineStyle = xlDash

'背景色
rng.Interior.Color = vbRed





'Application.Union.Borders.



End Sub

Sub rrr()

Dim rng As Range

Set rng = Cells(1, 1)
'rng.Select



Set rng = Union(rng, Cells(3, 4))
rng.Select

'rng.Borders.Color = vbRed
'rng.Borders.LineStyle
rng.Borders(xlEdgeTop).LineStyle = xlContinuous
rng.Borders(xlEdgeLeft).LineStyle = xlContinuous
rng.Borders(xlEdgeRight).LineStyle = xlContinuous
rng.Borders(xlEdgeBottom).LineStyle = xlContinuous

Set rng = Nothing


Set rng = Cells(7, 7)
'rng.Select

Set rng = Union(rng, Cells(10, 12))
rng.Select
rng.BorderAround LineStyle:=xlContinuous

rng.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
'rng.Borders.LineStyle = xlLineStyleNone

rng.Borders(xlEdgeBottom).LineStyle = xlDash

'背景色
rng.Interior.Color = vbBlue





'Application.Union.Borders.

End Sub

Sub qqq()

Dim rng As Range

Set rng = Range("B1")
'rng.Select



Set rng = Union(rng, Range("A2:C3"))
rng.Select

'rng.Borders.Color = vbRed
'rng.Borders.LineStyle
rng.Borders(xlEdgeTop).LineStyle = xlContinuous
rng.Borders(xlEdgeLeft).LineStyle = xlContinuous
rng.Borders(xlEdgeRight).LineStyle = xlContinuous
rng.Borders(xlEdgeBottom).LineStyle = xlContinuous

Set rng = Nothing


Set rng = Range("B1")
'rng.Select

Set rng = Union(rng, Range("E2:F3"))
rng.Select
rng.BorderAround LineStyle:=xlContinuous

rng.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
'rng.Borders.LineStyle = xlLineStyleNone

rng.Borders(xlEdgeBottom).LineStyle = xlDash

'背景色
rng.Interior.Color = vbRed





'Application.Union.Borders.

End Sub

VBA

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