VBAで取引先コード事にシートを作成したい

Question

A列のコード数字2桁~6桁を元にシートを分ける。(今回の質問)

シート内の特定のセルから値を取得して、CSV形式で保存する。(最終形)

困っていること

現在のコードだと1回で、終了してしまいます。
A列の取引先コードの数は決まっていません。取引先毎に出力するにはどうすればいいのでしょうか？

現在のシート

|||

取引先CD	請求先郵便番号	請求先住所1
20010	xxx-xxxx	xx県xx市
20010	xxx-xxxx	xx県xx市
20022	xxx-xxxx	xx県xx市
20022	xxx-xxxx	xx県xx市
20099	xxx-xxxx	xx県xx市

Option Explicit

Sub cutxlsx()

'xlsxファイルが存在するかの確認
Dim rs As Boolean
If OpenFileName1 <> "" Then
    Workbooks.Open OpenFileName1
    rs = True
Else
    MsgBox "Excelファイルを指定してください。"
    rs = False
End If

If rs = True Then 'xlsxを開いていれば処理を進める

'WorkBookを開いてActiveにさせる
Workbooks(Filename1).Activate

'WorkBookに開いたファイルのSheet1を保存、今後【ws】で呼び出せる
Dim ws As Worksheet
Dim wsname As String
Dim wsnumber As Integer
Set ws = ActiveSheet '現在のシート

'A列を文字列から数値に置換(エラー回避)
With Intersect(ActiveSheet.UsedRange, Columns("A"))
    .NumberFormat = ""
    .Value = .Value
End With

'Sheet名の決定
wsname = "Sheet"
wsnumber = 2

'Sheetの追加
     Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
     .name = (wsname & wsnumber) 'シート名はFor文で回して被らないようする
     
'ここからFor文で囲う必要あり
     
Sheets("Sheet1").Rows(1).Copy 'ヘッダーをコピー
Sheets(wsname & wsnumber).Rows(1).PasteSpecial (xlPasteAll)  'ヘッダーを貼付

ws.Activate 'Sheet1をActivate

Dim i As Integer
Dim j As Integer
Dim r As Integer
Dim lastRow As Long

r = 2 '結果表示の初期値
i = 2 '現在の比較行

lastRow = Cells(Rows.Count, "A").End(xlUp).Row 'A列最終行までを取得

For j = 2 To lastRow '注目行を2行目からA列最終行まで

    If ws.Cells(i, "A") = ws.Cells(j, "A") Then 'A列の比較元行の値と注目行の値が同じ

        ws.Rows(j).Copy Sheets(wsname & wsnumber).Rows(r) '注目行を"test"シートの結果
        r = r + 1 '結果表示行+1
End If
    
Next
wsnumber = wsnumber + 1 'Sheet名+1
End If 'xlsxファイルの存在確認

End Sub

コード修正致しました。しかし、このコードでは10あるうち8行で止まってしまいます。
恐らくElseの分がFor rの方でカウントされてしまうからのようで、どのようにすれば総実行回数を割り出せるのでしょうか？この時、取引先は全てで4つで実験しています。

For r = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row '取引先コードの分だけ処理する

        '取引先CDが同じ場合
     If ws.Cells(o, "A") = CD.Cells(j, "A") Then      '1つ下の行と値が同じ場合
        ws.Rows(o).Copy Sheets(wsname & wsnumber).Rows(k) '一致した場合コピー
        o = o + 1 'コピー先がひとつ下がる
        k = k + 1
     Else
        '取引先コードが変わった時
        wsnumber = wsnumber + 1 'Sheetを1足して作成
        Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
        .name = (wsname & wsnumber)   'Sheetの追加
        Sheets("Sheet1").Rows(1).Copy 'ヘッダーをコピー
        Sheets(wsname & wsnumber).Rows(1).PasteSpecial (xlPasteAll)  'ヘッダーを貼付
        j = j + 1 '取引先コードの分だけループなので、ひとつ下がる
        k = 2
    End If

Comments

[m.ts10806]

元のシートにはどのように並んでいるのでしょうか。
また、「1回で終了」というのはどういう意味でしょうか

[kingkamehameha]

元のシート追加致しました。項目名は20行程あるので、割愛して先頭の3行を表示しています。
追加したシートですと、20010のCD分だけ回って終了になります。コード自体がそういった仕様なので、VBAはそれに従っているまでとは分かっているのですが、、、

[hatena19]

取引先CD で昇順に並んでいるのですか。
あるいは、並んでいない場合、昇順に並び替えてもいいですか。

[kingkamehameha]

取引先は全て昇順で並んでいます。

Answer 1

以下のように、1件のデータが1行に対応していて、取引先コードごとにシートを作成してまとめたい、ということでしょうか。

取引先コード	ほげ	ふが
001	2020-01-01	200
003	2020-01-04	400
002	2020-01-02	800
001	2020-01-08	200

概念的に考えてみました。
しっかりと確認していないので、間違いがあるかもしれません。

確認済み取引先コード = []  ←シート内のどこかを使うか、取引先の数を超える大きさの配列を用意

for (i = 1行目; i != 空行（最終行を超えている）; i++)
{
    if ( 確認済み取引先コード に i行A列 の数字が含まれていない )
    {
        k = 1
        sheet = シート作成（シート名は取引先コード）

        for (j = i; j != 空行（最終行を超えている）; j++)
        {
            if (i行A列 == j行A列)
            {
                 sheet の k行目 に j行目 のデータを追加
            }
            k++
        }

        確認済み取引先コード に i行A列 の数字を追加
    }
}

Comments

[kingkamehameha]

そのような感じで一度組んでみましたが、総実行回数が行数分なので、Elseに回った分だけ行数が減ってしまいます。この場合どうするのがベターでしょうか？
変数 = EndXlup.Rowで数字に直してElseに回った分だけ、変数から-1していくのがいいのでしょうか？
現時点で結構、重たい処理なので悩んでいます。

[programming]

コピー処理ですが、以下のページを参考に、コピーではなく代入してはいかがでしょうか。
http://officetanaka.net/excel/vba/speed/s13.htm

[kingkamehameha]

有難う御座います。尚且つ、シート1枚毎にCSVに出力するようにしたいと思います。

[programming]

こちらのサイトを参考に全シートをforでたどりながら、シート名が条件に合致する（取引先コードになっているとか）シートを処理します。
https://bayashita.com/p/entry/show/114

こちらのサイトを参考にすると、CSVで書き出せると思います。
https://tonari-it.com/vba-write-csv/

Answer 2

流としてはこんな感じになると思います。
まずは解読してみてください。

Option Explicit

Sub メイン()
    Dim wb As Workbook
    Dim sFullPath As String

    '開くファイルを選択してファイルのフルパスを取得
    sFullPath = Application.GetOpenFilename()
    'キャンセルされたらプログラムを抜ける
    If sFullPath = "False" Then Exit Sub
    'ファイルを開く
    Set wb = Workbooks.Open(sFullPath)

    CD毎に分けてCSVに保存 wb

    '開いたファイルを閉じる
    wb.Close False
End Sub

'CD毎に分けてCSVに保存
Sub CD毎に分けてCSVに保存(ByRef wbk As Workbook)
    Dim rngCode As Range
    Dim c As Range
    Dim sCode As String
    Dim ws As Worksheet

    '順次見て行くセル範囲を限定
    With wbk.Worksheets(1).UsedRange
        Set rngCode = .resiz(.Rows.Count - 1, 1).Offset(1)
    End With

    'セル範囲の内の各セルを順次見て行く
    For Each c In rngCode
        'Code番号を取得（セルの値を取得）
        sCode = CStr(c.Value)
        'シートの存在確認
        On Error Resume Next
        Set ws = wbk.Worksheets(sCode)
        On Error GoTo 0

        'もしなければ、新たに作り結果を出力(あれば何もしない）
        If ws Is Nothing Then
            EachElementToCSV sCode, rngCode
        End If
    Next
End Sub

'Codeで抽出しCsv形式で保存
Sub EachElementToCSV( _
    ByVal sCode As String, _
    ByRef rngList As Range)
    Dim wsResult As Worksheet
    Dim wbk As Workbook

    Set wbk = .Worksheet.Parent
    With rngList.CurrentRegion
        '同じコードの抽出先を用意
        With wbk
            .Worksheets.Add After:=.Worksheets(.Worksheets.Count)
            Set wsResult = .Worksheets(.Worksheets.Count)
        End With

        '同じコードの抽出
        .AutoFilter 1, sCode
        '転記先へコピペ
        .Copy wsResult.Cells(1)
    End With

    Application.DisplayAlerts = False
    'CSV形式で保存
    wbk.SaveAs Replace(wbk.Path, "????", sCode), xlCSV
End Sub

※Code毎にシートを作成していますが、
大量のシートが出来ることは現実的ではないと思います。
まずは少ないデータ数で動作確認をし、
ステップインで1行づつ実行し、作業の流れを今一度把握してみてください。

Answer 3

コードを拝見するに、ファイルをオープンし、末端までのループ
処理は存在しますが、CDのシートの内容分ループさせてないので
1回分のループで終わるのではないでしょか？
CDのシートに記載されている個数分ループさせ
さらにそのシートを開いて、ループ処理で末端処理まで
させればよいのではないでしょか？

Comments

[kingkamehameha]

仰っている事は、きっと実現したい事と一致するのですがコードが思いつきません。

[nanami12]

単純に考えて下さい。取引先コードを末端までループする大ループの中に
その開いたページの中を末端まで処理する小ループ処理を２つ作ればよいだけです。

[kingkamehameha]

そのような感じで組んでみましたが、Elseに回った分だけ処理行が減ってしまいました。

[nanami12]

小ループの処理はできているわけですから、大ループの処理を追加すればよいだけかと
またelseにhogehogeの処理が減ったの意味が分かりません。

[nanami12]

>しかし、このコードでは10あるうち8行で止まってしまいます。
>恐らくElseの分がFor rの方でカウントされてしまうからのようで、
>どのようにすれば総実行回数を割り出
>せるのでしょうか？この時、取引先は全てで4つで実験しています。

10こ処理を行わなければならないのに8こでとまっているのであれば
グローバルな変数を用意し、行わなければならない回数を保持し
フラグ処理で処理が行われたらカウントアップし
グローバル宣言した変数に書かれた処理数と一致しているか
確認する処理を追加すればよいだけかと

[kingkamehameha]

全ての行数をカウントしてelseに回った場合だけ、全ての行数からマイナス1とする事で実現出来ました。