|
Sheet1のリストをSheet2のタックシールに配置する方法を
先日こちらで教えていただき、少し手を加えましたところ、最後のタックシールに余分な文字が出てしまいます。どうすれば出なくなるのか、全然解かりません。
どうかお知恵をお貸し下さい。
Dim lngRow As Long
Dim lngTuckRow As Long
Dim cntCT As Integer
lngTuckRow = 1
'Sheet1の5行目〜30行目までを処理する場合
For lngRow = 5 To 30
Sheets("Sheet2").Range("A" & lngTuckRow).Value = Sheets("Sheet1").Range("A" & lngRow).Value
Sheets("Sheet2").Range("A" & lngTuckRow).Interior.ColorIndex = 1
Sheets("Sheet2").Range("A" & lngTuckRow).Font.ColorIndex = 2
Sheets("Sheet2").Range("A" & lngTuckRow + 1).Value = Sheets("Sheet1").Range("E" & lngRow).Value
Sheets("Sheet2").Range("A" & lngTuckRow + 2).Value = Sheets("Sheet1").Range("B" & lngRow).Value
Sheets("Sheet2").Range("A" & lngTuckRow + 3).Value = Sheets("Sheet1").Range("C" & lngRow).Value
Sheets("Sheet2").Range("A" & lngTuckRow + 4).Value = Sheets("Sheet1").Range("D" & lngRow).Value & " " & Range("F" & lngRow) & "入"
cntCT = Sheets("Sheet1").Range("G" & lngRow).Value
If cntCT >= 2 Then
Sheets("Sheet2").Range("A" & lngTuckRow).Resize(6).Copy Sheets("Sheet2").Range("B" & lngTuckRow)
If cntCT >= 2 Then
Sheets("Sheet2").Range("A" & lngTuckRow).Resize(6, 2).Copy _
Sheets("Sheet2").Range("A" & lngTuckRow).Resize(6 * Int((cntCT + 1) / 2), 2)
End If
'C/T数が奇数の場合は、B列の最終行から6行を消去
If cntCT Mod 2 = 1 Then
Sheets("Sheet2").Range("B" & lngTuckRow).Offset(6 * Int(cntCT / 2)).Resize(6).ClearContents
End If
End If
lngTuckRow = lngTuckRow + 6 * (Int((cntCT + 1) / 2))
Next
Sheet2.Select
End Sub
|
|