2010年09月16日

久しぶりのマクロ。


今、仕事で「一覧にまとまっているものを個別シートに分割する」っていうマクロが欲しかったんだけど
別に必須じゃないから、マクロを考える時間がなかったので
家で考えました。

会社に持っていく手段がないので、貼り付け。

VBAとか忘れまくってるから、全ての行がうまく動かなかったし、
1行書くたびにgoogle先生におせわになったぜ・・・

Sub Macro1()

    'タイトル(ヘッダーのはじめのセル)
    Dim headerCol As Long   '列
    Dim headerRow As Long   '行
    'タイトル(ヘッダーの終わりのセル)
    Dim headerEndCol As Long    '列
    Dim headerEndRow As Long    '行
    'シート分割する基準列(業務分類)
    Dim gyomuCol As Long
    'シート分割する基準のマスタがある列
    Dim gyomuMstCol As Long
    '全体一覧シート名
    Dim mainSheetName As String
    
    '業務分類名
    Dim bunruiName As String
    'カウンタ
    Dim i, j As Long
    'シート名
    Dim sh As Worksheet
    
    '#### 設定 ###########################
    'タイトル(ヘッダーのはじめのセル)
    headerCol = 2       'B  '列
    headerRow = 2       '2  '行
    
    'タイトル(ヘッダーの終わりのセル)
    headerEndCol = 9    'I  '列
    headerEndRow = 2    '2  '行

    'シート分割する基準列(業務分類)
    gyomuCol = 8        'H

    'シート分割する基準のマスタがある列
    gyomuMstCol = 12    'L

    'メインシート名
    mainSheetName = "Sheet1"
    
    '###################################


    'Application.ScreenUpdating = False

    With Sheets(mainSheetName)

        '入力最後の行
        Dim lastRow As Long
        lastRow = .Cells(65535, headerCol + 1).End(xlUp).Row
    
        'マスタ最後の行
        Dim gyomuMstLastRow As Long
        gyomuMstLastRow = .Cells(65535, gyomuMstCol).End(xlUp).Row


        'メインシート以外削除
        For Each sh In Sheets
            If sh.Name <> mainSheetName Then
                Application.DisplayAlerts = False
                sh.Delete
                Application.DisplayAlerts = True
            End If
        Next


        '業務分類分シート作成
        For i = gyomuMstLastRow To headerRow + 1 Step -1
            bunruiName = .Cells(i, gyomuMstCol).Value
    
            'シート作成
            Sheets.Add(after:=Sheets(mainSheetName)).Name = bunruiName
            
            'タイトル行コピー
            .Range(.Cells(headerRow, headerCol), .Cells(headerEndRow, headerEndCol)).Copy Sheets(bunruiName).Cells(headerRow, headerCol)

        Next i


        'コピー開始
        For i = gyomuMstLastRow To headerRow + 1 Step -1
            bunruiName = .Cells(i, gyomuMstCol).Value
            
            '全体一覧分繰り返し
            For j = headerCol + 1 To lastRow
                If .Cells(j, gyomuCol).Value = bunruiName Then
                
                    '行コピー
                    .Range(.Cells(j, headerCol), .Cells(j, headerEndCol)).Copy Sheets(bunruiName).Cells(Sheets(bunruiName).Cells(65536, headerCol + 1).End(xlUp).Row + 1, headerCol)
                 
                End If
                
            Next j
        Next i
        
        'メインシート以外セルの幅をそろえる
        For Each sh In Sheets
            If sh.Name <> mainSheetName Then
                sh.Range(sh.Cells(headerRow, headerCol), sh.Cells(headerEndRow, headerEndCol)).EntireColumn.AutoFit
            End If
        Next
        
        'シートアクティブ化
        .Activate
        
    End With
    
    Application.ScreenUpdating = True


    MsgBox "分別化完了"
End Sub



マクロテスト.zip


posted by tsupo at 23:21| Comment(0) | TrackBack(0) | 覚書き | このブログの読者になる | 更新情報をチェックする
この記事へのコメント

この記事へのトラックバック
×

この広告は180日以上新しい記事の投稿がないブログに表示されております。