Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


69224 / 76738 ←次へ | 前へ→

【12032】Re:行選択
回答  Asaki  - 04/3/22(月) 16:44 -

引用なし
パスワード
   次に、ある特定のデータだけでなく、全データを種類別に別のブックにコピーする処理を考えます。

手順としては、
For 〜 Next でA列をループ
値が1行前と同じならカウントアップ
値が変わったら別ブックに書き出し

全データをループするので、
>文字 = InputBox("データを入力して下さい。")
は不要です。
代わりに、この変数には、1行前の値を入れておくのに利用します。

で、↓のような感じです。
Sub Test2()

Dim カウント As Integer
Dim 文字 As String
Dim 行 As String
Dim i  As Long
Dim sh As Worksheet
Dim j  As Long

  Set sh = ThisWorkbook.ActiveSheet
 
  カウント = 0
'  文字 = InputBox("データを入力して下さい。")
  文字 = Range("A2").Text
  j = 1
  For i = 2 To Range("A1").End(xlDown).Row + 1
    If sh.Range("A" & i).Text = 文字 Then
      If カウント = 0 Then
        行 = i & ":" & i
        カウント = 1
      Else
        行 = 行 & "," & i & ":" & i
      End If
    Else
        Workbooks.Add
        sh.Range(行).Copy Destination:=ActiveSheet.Cells(1, 1)
        ActiveWorkbook.SaveAs Filename:= _
          "C:\Documents and Settings\g0238\My Documents\Book" & j & ".xls", FileFormat:= _
          xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
          , CreateBackup:=False
        ActiveWindow.Close
        文字 = sh.Range("A" & i).Text
        j = j + 1
        行 = i & ":" & i
    End If
  Next

End Sub


問題は、保存するときのファイル名ですが、取り敢えず連番にしておきました。

先ほどの、ある特定のデータのみをコピーする処理中のループは、以下のように変更してください。
>For i = 1 To Range("A2").End(xlDown).Row

For i = 2 To Range("A1").End(xlDown).Row

0 hits

【12023】行選択 Hm 04/3/22(月) 13:30 質問
【12024】Re:行選択 Asaki 04/3/22(月) 14:08 回答
【12025】Re:行選択 ぴかる 04/3/22(月) 14:54 回答
【12026】Re:行選択 Hm 04/3/22(月) 14:58 質問
【12027】Re:行選択 Asaki 04/3/22(月) 15:08 回答
【12028】Re:行選択 Hm 04/3/22(月) 15:27 質問
【12030】Re:行選択 Asaki 04/3/22(月) 16:05 回答
【12032】Re:行選択 Asaki 04/3/22(月) 16:44 回答
【12036】Re:行選択 Hm 04/3/22(月) 17:02 質問
【12037】Re:行選択 Asaki 04/3/22(月) 17:08 回答
【12039】Re:行選択 ぴかる 04/3/22(月) 17:15 発言
【12041】Re:行選択 Asaki 04/3/22(月) 17:16 発言
【12048】Re:行選択 Hm 04/3/22(月) 17:48 お礼

69224 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free