|
おはようございます。
項目4つあったんですね。
sheet1 から sheet2に分類します。
シート名は適宜変更してください。
Sub 分類2()
Dim i As Long
Dim k As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
sh2.Cells.Clear
sh1.Rows(1).Copy sh2.Range("A1")
For i = 2 To sh1.Range("A65536").End(xlUp).Row
For k = 1 To sh1.Cells(i, "A").End(xlToRight).Column - 2 Step 3
Select Case sh1.Cells(i, k)
Case 0, 1
If sh2.Cells(i, "A") = "" Then
sh1.Cells(i, k).Resize(1, 3).Copy sh2.Cells(i, "A")
Else
sh1.Cells(i, k).Resize(1, 3).Copy sh2.Range("IV" & i).End(xlToLeft).Offset(, 1)
End If
Case 2
If sh2.Cells(i, "P") = "" Then
sh1.Cells(i, k).Resize(1, 3).Copy sh2.Cells(i, "P")
Else
sh1.Cells(i, k).Resize(1, 3).Copy sh2.Range("IV" & i).End(xlToLeft).Offset(, 1)
End If
Case 3
If sh2.Cells(i, "AB") = "" Then
sh1.Cells(i, k).Resize(1, 3).Copy sh2.Cells(i, "AB")
Else
sh1.Cells(i, k).Resize(1, 3).Copy sh2.Range("IV" & i).End(xlToLeft).Offset(, 1)
End If
Case 4
If sh2.Cells(i, "AN") = "" Then
sh1.Cells(i, k).Resize(1, 3).Copy sh2.Cells(i, "AN")
Else
sh1.Cells(i, k).Resize(1, 3).Copy sh2.Range("IV" & i).End(xlToLeft).Offset(, 1)
End If
End Select
Next k
Next
|
|