Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : Excel 2010)
セル範囲の繰り返し取得の「入れ子」を教えてください。
投稿日時: 20/06/21 09:38:14
投稿者: bulue LINE

コード(会社名)ごとのデータがA列からN列まであり、コードごとにシートを作成しデータを転記するマクロを作成しようとしています。
 
B列をベースにコード(会社名)ごとにソートしており、B列が異なる場合に新しいシートを追加することまではできたのですが、変動するセル範囲の取得ができません。
 
恐らく、ネストにより解決するものと思われますが、知識不足でコードが書けません。
 
お手数ですが、解決方法を教えてください。
また、データが大量となる場合もありますので、操作に負荷がかからないマクロがあれば合わせて教えてください。
 
よろしくお願いいたします。
 
 
Sub コード単位シート作成()
 
    Dim i As Integer
    Dim 最終行 As Long
     
    最終行 = Worksheets(1).Cells(9, 1).CurrentRegion.Rows.Count + 8
    For i = 10 To 最終行
        If Sheets(1).Cells(i, 2).Value <> Sheets(1).Cells(i + 1, 2).Value Then
            Worksheets.Add after:=Sheets(Sheets.Count)
            Sheets(1).Range("A9:N9").Copy
     '& Cells(i, 1).Resize(1, 14).Copy                ……ここでセル範囲データを取得すればよいのでしょうか?コードが書けません。
  Sheets(Sheets.Count).Select
              Cells(1, 1).Select
                With Selection
                    .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                         SkipBlanks:=False, Transpose:=False
                End With
              ActiveSheet.Paste
        End If
    Next
  
End Sub

回答
投稿日時: 20/06/21 11:35:50
投稿者: WinArrow
投稿者のウェブサイトに移動

考え方のヒント
 
いろんな考え方がいますが、とりあえず・・・
(1)会社名のユニークなデータを作成します。
(2)ユ二−クな会社名でオートフィルタをかけます。
(3)検索したデータを該当するシートに複写します。
 
(2)〜(3)の処理を、ユ二−クな会社名分繰り返します。
 
※シートを追加する作業は、(1)の後、まとめて実行したほうがよい。
  (シート名を会社名にすることを含めて)
※シートを選択(SELECT)したり、セル範囲を選択したりする操作は、処理時間が掛かるのでやめる
 SELECTしなくても複写はできます。
※ループ処理も極力減らすこと。
 

回答
投稿日時: 20/06/21 11:48:31
投稿者: WinArrow
投稿者のウェブサイトに移動

↑の(1)
の部分のコードの参考例を提示します。
 
Sub Sample1()
     
    Dim Dic, i As Long, buf As String, KEYS
     
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 10 To Range("B" & Rows.Count).End(xlUp).Row
        buf = Cells(i, "B").Value ''セルの値を変数bufに格納する
        If Not Dic.Exists(buf) Then ''まだ登録されていなかったら…
            Dic.Add buf, buf ''セルの値を連想配列に登録する
        End If
    Next i
         
    KEYS = Dic.KEYS
    For i = 0 To Dic.Count - 1
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = KEYS(i)
    Next i
    Sheets(1).Activate
 
End Sub

投稿日時: 20/06/21 14:45:01
投稿者: bulue LINE

WinArrow 様
早速、ご回答いただきありがとうございます。
 
教えていただいた内容でマクロを動かしましたが、会社後のシートの追加はできました。
 
データはオートフィルターを使用してマクロを自分なりに考えて以下の通り追記しましたが、うまく動きません。
 
どのように記述したら良いか大変お手数ですが、教えてください。
 
ベースのシート(一番左)の9行目を追加する各シートのヘッダー(1行目)とするようにしています。
 
Sub 修正D()
       
     Dim Dic, i As Long, buf As String, KEYS
       
     Set Dic = CreateObject("Scripting.Dictionary")
     For i = 10 To Range("B" & Rows.Count).End(xlUp).Row
         buf = Cells(i, "B").Value ''セルの値を変数bufに格納する
        If Not Dic.Exists(buf) Then ''まだ登録されていなかったら…
            Dic.Add buf, buf ''セルの値を連想配列に登録する
        End If
     Next i
           
     KEYS = Dic.KEYS
     For i = 0 To Dic.Count - 1
         Sheets.Add After:=Sheets(Sheets.Count)
         Sheets(1).Range("A9:N9").Copy
            Sheets(i).Range("A1").Select  ここで動きません。
                With Selection
                    .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                         SkipBlanks:=False, Transpose:=False
                End With
              ActiveSheet.Paste
              Selection.RowHeight = 27
         Sheets(1).Range(Cells(9, 1), Cells(9, 14)).AutoFilter Field:=2, Criteria1:=buf ここもおかしいような気がします
  'オートフィルター実行
         Sheets(1).Range(Cells(9, 1), Cells(9 + i, 14)).Copy Sheets(i).Range("A2")           '結果をコピーする
         Sheets(1).AutoFilterMode = False
         ActiveSheet.Name = KEYS(i)
 
     Next i
     Sheets(1).Activate
     Range("A9").Select

回答
投稿日時: 20/06/21 15:43:09
投稿者: WinArrow
投稿者のウェブサイトに移動

何か勘違いしていませんか?
  
私が提示したコードは
(1)の部分だけです。
※(1)のコードの中で
  セル範囲の複写は必要ありません。
   結果としてちゃちゃめちゃなコードになっています。
  
※オートフィルタの使い方をもっと勉強したほうがよいでしょうね。
  
   
全操作の参考コードを提示します。
Sub Sample1()
       
     Dim Dic, i As Long, buf As String, KEYS
'(1)STEP
     Set Dic = CreateObject("Scripting.Dictionary")
     For i = 10 To Range("B" & Rows.Count).End(xlUp).Row
         buf = Cells(i, "B").Value ''セルの値を変数bufに格納する
        If Not Dic.Exists(buf) Then ''まだ登録されていなかったら…
            Dic.Add buf, buf ''セルの値を連想配列に登録する
        End If
     Next i
           
     KEYS = Dic.KEYS
     For i = 0 To Dic.Count - 1
         Sheets.Add After:=Sheets(Sheets.Count)
         ActiveSheet.Name = KEYS(i) '➀
     Next i
     Sheets(1).Activate
 
    With Sheets(1)
        .Range("A9").AutoFilter
        For i = 0 To Dic.Count - 1
'(2)STEP
            .Range("A9:N" & .Rows.Count).End(xlUp).AutoFilter Field:=2, Criteria1:=KEYS(i) 'A
'(3)STEP
            .Range("A9").CurrentRegion.Copy Destination:=Sheets(KEYS(i)).Range("A1") 'B
        Next
        .Range("A9").AutoFilter
    End With
     
    Set Dic = Nothing
End Sub
 
➀ABは、ユニークにした会社名を使っているところです。
 
  
 

投稿日時: 20/06/21 16:27:31
投稿者: bulue LINE

WinArrow 様
 
全体のコードのご提案ありがとうございます。
 
オートフィルターの設定範囲の理解が足らず、お手数をおかけしました。
自分がイメージしている通りにシートが作成できました。
知識をつけて適切なマクロが記載できるようにします。
 
スッキリとしたコードでデータが多いときも操作時間が少なくて済みそうです。
ずっと悩んでいましたので本当に助かりました。
 
重ねてお礼申し上げます。
今後ともよろしくお願いいたします。