| 
    
     |  | 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
 
 |  |