Excelのシート分け。結合セルがある表を、ある項目ごとにシート分けをする方法をご伝授ください。
ALLというシートがあり、A列：会員No、B列：氏名、C列：都道府県とあり、各4行で結合してあります。
各データは、名簿一覧シートから参照して、A列、B列、C列は埋まっています。
名簿一覧で、データの追加、削除されると、自動的にALLのシートも更新をされます。
また、D列以降は、一行ごとに個別のデータが入っています。
このALLシートを、C列の都道府県ごとにシート分けをするマクロを作成していますが上手くいきません。
都道府県ごとにシート分けをしシート名は都道府県名で作成のマクロに関して、ご伝授のほど
よろしくお願い致します。
No.1
5
2
700pt
マクロコードを書きやすいデータ配列を検討したほうがいいのかなぁ・・・
1レコード（1行）が 会員No，氏名，都道府県，情報区分，日付，個別のデータ にするとか。
No.1
52
ここでベストアンサー
700pt
マクロコードを書きやすいデータ配列を検討したほうがいいのかなぁ・・・
1レコード（1行）が 会員No，氏名，都道府県，情報区分，日付，個別のデータ にするとか。
セル結合されているのでそのようには見えないだけですが，各4行のセル結合なので行単位ごとに必ず空白セルが３つあります。なので，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行固定でしたので上記のコードでシート分けすることができました。ありがとうございます！
20
19
1
2
セル結合されているのでそのようには見えないだけですが，各4行のセル結合なので行単位ごとに必ず空白セルが３つあります。なので，1列目から3列目の間で順番に行を見ていくやり方はうまく動かないと思います。それでも行のかたまりが4行単位で決まっているなら，次のような感じにするといいかもしれません。
2017/11/13 01:44:48Sub 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行固定でしたので上記のコードでシート分けすることができました。ありがとうございます！
2017/11/13 21:11:07