Word (VBA)

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

 
(Windows 10 Pro : Word 2010)
連続したワークシートの連番の付け方
投稿日時: 18/10/21 23:41:52
投稿者: FANTA66

いつも皆様の内容を参考にさせていただき大変助かっております。
 
私はExcelVBAの初心者です。掲題につきまして質問がございます。
どうぞよろしくご指導をいただけますようお願い申し上げます。
 
では、質問に入らせていただきます。
今回はExcelにインポートした「品物請求者リスト」を品物コードごとのシートに分ける場合です。
@「品物請求者リスト」から"品物コードと"品物名"を抽出。
Aそこから、追加したワークシートを順次作成し、タグ名に"品物コード"を付ける。
Bその各ワークシートに"品物コードで該当者のみを「品物請求者リスト」をコピー。
Cコピー先の「品物請求者リスト」に連番を附番してゆく。
 補足「品物請求者リスト」の一行目は項目行です。
   また、連番は項目行を0番として整数で附番します。
 
実は、結果として、問題なく動作するのですが・・・、
なぜか、「品物請求者リスト」に一人しか請求者がいない場合に
一番下の1048576行までのすべてに附番されてしまいます。
 
二人以上の請求者が存在する場合は該当する件数だけの附番できています。
しかし、なぜか一人しか請求者がいない場合にうまくゆきません。
これを防ぐ方法を教えていただけないでしょうか?
以下が作成したコードです。
 
Sub 新たなワークシートの挿入()
    Dim i As Long
    Dim FileName As String
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
       '二枚目のワークシートから一枚ずつ新ワークシートを追加してゆく
      FileName = Worksheets("品物請求確認結果").Range("A" & i).Value
       '変数FileNameに「品物コード」をファイル名として取得する
      Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = FileName
       '追加した一枚目のワークシート名として「品物コード」をファイル名として貼り付ける
      Worksheets("品物請求抽出結果").Range("E2").Value = FileName
             
      Dim DataRange As Range, Criteria As Range, CopyTo As Range
      Dim blnUnique As Boolean
        '変数として「DataRange」、「Criteria」、「CopyTo」及び「blnUnique」設定
      Set DataRange = Worksheets("台帳データ出力結果").Range("F7")
        '「DataRange」には、ワークシート「台帳データ出力結果」の"F7"(=品物コード)を設定。
      Set Criteria = Worksheets("品物請求抽出結果").Range("A1:L2")
        '「Criteria」には、ワークシート「品物請求抽出結果」に必要とする"A1からL2"を設定。 _
        '(=会員番号、氏名漢字、代表支払会員番号、引換番号、品物コード、摘要、数量、請求額、 _
        '支払方法、請求書発行予定日、入金年月日、入金額)を設定。
      Set CopyTo = Worksheets("品物請求抽出結果").Range("A10:L10")
        '「CopyTo」には、ワークシート「品物請求抽出結果」に必要とする"A10からL10"を設定。 _
        '(=会員番号、氏名漢字、代表支払会員番号、引換番号、品物コード、摘要、数量、請求額、 _
        '支払方法、請求書発行予定日、入金年月日、入金額)の項目を抽出。
      blnUnique = True
        '「blnUnique」は重複データについての設定。
      AdvancedFilter DataRange, Criteria, CopyTo, blnUnique
        '「AdvancedFilter」は別にオールラウンドなプログラムとして設定。
      Worksheets("品物請求抽出結果").Range("A10").CurrentRegion.Copy Destination:= _
      Worksheets(FileName).Range("B1")
        '品物請求抽出結果から、品物コードの一致するワークシートにコピーする。
         
      Dim j As Long
        '変数として「j」を設定する
      j = 1
          For j = 1 To Worksheets(FileName).Range("B2").End(xlDown).Row
            '「品物コードの一致するワークシート」にコピーしたデータの1行目が項目行のため、_
            'データが存在するセルB2から最終までの行数を取得する。
          Worksheets(FileName).Range("A" & j).Value = j - 1
            '連番を振るときに "スタート行=0行目(項目行)" と考え、_
            '始まりの "0"=「A1」 になるよう 右辺の値を i - 1 と設定する。
          Next j
    Next i
End Sub
 
以上です。
よろしくご指導をいただけますようお願い申し上げます。

回答
投稿日時: 18/10/22 10:06:50
投稿者: sk

引用:
私はExcelVBAの初心者です。

こちらは Word VBAに関するフォーラムです。
 
引用:
Cコピー先の「品物請求者リスト」に連番を附番してゆく。
 補足「品物請求者リスト」の一行目は項目行です。
   また、連番は項目行を0番として整数で附番します。

引用:
なぜか、「品物請求者リスト」に一人しか請求者がいない場合に
一番下の1048576行までのすべてに附番されてしまいます。

引用:
For j = 1 To Worksheets(Filename).Range("B2").End(xlDown).Row
  '「品物コードの一致するワークシート」にコピーしたデータの1行目が項目行のため、_
  'データが存在するセルB2から最終までの行数を取得する。
Worksheets(Filename).Range("A" & j).Value = j - 1
  '連番を振るときに "スタート行=0行目(項目行)" と考え、_
  '始まりの "0"=「A1」 になるよう 右辺の値を i - 1 と設定する。
Next j

With Worksheets(Filename)
    For j = 1 To .Cells(.Rows.Count, "B").End(xlUp).Row
        .Range("A" & j).Value = j - 1
    Next j
End With

投稿日時: 18/10/22 23:23:12
投稿者: FANTA66

sk様。
すっかり見間違いをしていたようで大変失礼をいたしました。
ありがとうございました。