Seven Knightsさんのｺﾒﾝﾄ
どうしてもと言うなら，こんな感じでどうでしょうか？
Sub TEMP()
Dim F As Boolean
Set W = ActiveWorkbook
Set SA = W.Sheets("ALL")
CL = SA.Cells(3, 1).End(xlToRight).Column
For i = 4 To SA.Cells(3, 4).End(xlDown).Row
Select Case IsEmpty(SA.Cells(i, 1))
Case True
Case False
Call TEMP2(W, SA.Cells(i, 3), F)
Select Case F
Case True
Set SB = W.Sheets(Format(SA.Cells(i, 3)))
RW = SB.Cells(1, 4).End(xlDown).Row + 1
Case False
Sheets.Add after:=SA
Set SB = ActiveSheet
SB.Name = SA.Cells(i, 3)
Range(SA.Cells(3, 1), SA.Cells(3, CL)).Copy Destination:=SB.Cells(1, 1)
RW = 2
End Select
Range(SA.Cells(i, 1), SA.Cells(i + 3, CL)).Copy Destination:=SB.Cells(RW, 1)
End Select
Next i
End Sub
Sub TEMP2(W, SHEETNAME, F)
F = False
For Each S In W.Sheets
Select Case S.Name
Case SHEETNAME
F = True
Exit For
Case Else
End Select
Next
End Sub
にゃんころねさんのｺﾒﾝﾄ
ありがとうございます！
仕様で､ﾃﾞｰﾀ配列の変更ができないので質問しました｡
早速､実行してみて上手くいかなかったので､
For i = 4 To SA.Cells(3, 4).End(xlDown).Row を
For i = i + 4 To SA.Cells(3, 4).End(xlDown).Row
へ修正したら分けることができました｡
もう一点､修正したのがありまして､4列目の小分類｢情報4｣などが空欄の場合でも
分けるようにするには､どのように修正したら良いでしょうか？
※空欄の判定をA列､B列､C列のどれかで行いたいのです｡
再度､ご教示のほどお願い致します｡
Seven Knightsさんのｺﾒﾝﾄ
ｾﾙ結合されているのでそのようには見えないだけですが，各4行のｾﾙ結合なので行単位ごとに必ず空白ｾﾙが3つあります｡なので，1列目から3列目の間で順番に行を見ていくやり方はうまく動かないと思います｡それでも行のかたまりが4行単位で決まっているなら，次のような感じにするといいかもしれません｡
Sub TEMP()
Dim FLAG As Boolean
LABEL_ROW = 3 '会員番号，氏名，都道府県，日付，･･･のﾗﾍﾞﾙ行番号
ROW_UNIT = 4 '結合する行数
Set W = ActiveWorkbook
Set SA = W.Sheets("ALL")
RIGHTMOST_COLUMN = SA.Cells(LABEL_ROW, 1).End(xlToRight).Column
For i = LABEL_ROW + 1 To SA.Cells.SpecialCells(xlCellTypeLastCell).Row Step ROW_UNIT
Select Case IsEmpty(SA.Cells(i, 3))
Case True
SHEET_NAME = "都道府県未登録"
Case False
SHEET_NAME = Format(SA.Cells(i, 3))
End Select
Call TEMP2(W, SHEET_NAME, FLAG)
Select Case FLAG
Case True
Set SB = W.Sheets(SHEET_NAME)
NETHERMOST_ROW = SB.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Case False
Sheets.Add after:=SA
Set SB = ActiveSheet
SB.Name = SHEET_NAME
Range(SA.Cells(LABEL_ROW, 1), SA.Cells(LABEL_ROW, RIGHTMOST_COLUMN)).Copy Destination:=SB.Cells(1, 1)
NETHERMOST_ROW = 2
End Select
Range(SA.Cells(i, 1), SA.Cells(i + ROW_UNIT - 1, RIGHTMOST_COLUMN)).Copy Destination:=SB.Cells(NETHERMOST_ROW, 1)
Next i
End Sub
Sub TEMP2(W, SHEETNAME, FLAG)
FLAG = False
For Each S In W.Sheets
Select Case S.Name
Case SHEETNAME
FLAG = True
Exit For
Case Else
End Select
Next
End Sub
にゃんころねさんのｺﾒﾝﾄ
行は､4行固定でしたので上記のｺｰﾄﾞでｼｰﾄ分けすることができました｡ありがとうございます！ ▽2
●
moviehdapp
●0ﾎﾟｲﾝﾄ
Excelのｼｰﾄ分け｡結合ｾﾙがある表を､ある項目ごとにｼｰﾄ分けをする方法をご伝授ください｡
ﾍﾞｽﾄｱﾝｻｰ