Excel (VBA)

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

 
(Windows 10全般 : Excel 2013)
1500データごとに新規ブックにコピーしたい
投稿日時: 20/04/07 16:11:16
投稿者: vaioyuki

いつもお世話になっております。
またまたご教授ください。
 
送られてくるデータをエクスポートする際、1500件しか登録できないため区切りたいと思っています。
現在は多くて3つのブックくらい。。。と聞いているのですが、この先増える可能性はあります。
今は下記コードでとりあえずは4500まではないかなぁと思って作っています。(^^;
 

Sub Export()
Dim r As Long
Dim r_cnt As Long

Dim OldSheet As Worksheet

Set OldSheet = ActiveSheet

With Worksheets(2)
    r_cnt = .Range("A1").CurrentRegion.Rows.Count
    
    For i = 10 To r_cnt
        .Cells(i, 1) = .Cells(i, 1).Row
    Next
    
    Select Case r_cnt
        Case Is <= 1500
            Worksheets.Add.Name = "1500まで"
            .Rows("1:9").Copy Worksheets("1500まで").Rows("1")
            .Range("A1501:GQ" & r_cnt).Copy Worksheets("1500まで").Range("A10")

            ThisWorkbook.Worksheets("1500まで").Copy

            Application.DisplayAlerts = False
            ThisWorkbook.Worksheets("1500まで").Delete
            Application.DisplayAlerts = True
            
        Case Is <= 3000
            Worksheets.Add.Name = "1500まで"
            Worksheets.Add.Name = "1501から"
            .Rows("1:9").Copy Worksheets("1500まで").Rows("1")
            .Rows("1:9").Copy Worksheets("1501から").Rows("1")
            .Range("A10:GQ1500").Copy Worksheets("1500まで").Range("A10")
            .Range("A1501:GQ" & r_cnt).Copy Worksheets("1501から").Range("A10")

            ThisWorkbook.Worksheets("1500まで").Copy
            ThisWorkbook.Worksheets("1501から").Copy

            Application.DisplayAlerts = False
            ThisWorkbook.Worksheets("1500まで").Delete
            ThisWorkbook.Worksheets("1501から").Delete
            Application.DisplayAlerts = True
        
        Case Is <= 4500
            Worksheets.Add.Name = "1500まで"
            Worksheets.Add.Name = "1501から"
            Worksheets.Add.Name = "3001から"
            .Rows("1:9").Copy Worksheets("1500まで").Rows("1")
            .Rows("1:9").Copy Worksheets("1501から").Rows("1")
            .Rows("1:9").Copy Worksheets("3001から").Rows("1")
            .Range("A10:GQ1500").Copy Worksheets("1500まで").Range("A10")
            .Range("A1501:GQ3000" & r_cnt).Copy Worksheets("1501から").Range("A10")
            .Range("A3001:GQ" & r_cnt).Copy Worksheets("3001から").Range("A10")

            ThisWorkbook.Worksheets("1500まで").Copy
            ThisWorkbook.Worksheets("1501から").Copy
            ThisWorkbook.Worksheets("3001から").Copy

            Application.DisplayAlerts = False
            ThisWorkbook.Worksheets("1500まで").Delete
            ThisWorkbook.Worksheets("1501から").Delete
            ThisWorkbook.Worksheets("3001から").Delete
            Application.DisplayAlerts = True
    End Select
End With

OldSheet.Activate

MsgBox "処理完了"

End Sub

 
 
1行目から9行目までは固定なのでそれぞれコピーしています。(もしかしたらこれは変数になるのかなと思ったり。。。)
 
よろしくお願いいたします。

投稿日時: 20/04/07 16:13:49
投稿者: vaioyuki

【追記です】
A列に行番語が表記されるので特にシート名にこだわりはありません。
よろしくお願いいたします。

回答
投稿日時: 20/04/07 17:23:30
投稿者: WinArrow
投稿者のウェブサイトに移動

話が見えないとところがあります。
 
誤解しているかもしれないので確認のため
 
まず、「エクスポート」とは、出力という意味なんですが、
どこから、どこへエクスポートすんでしょうか?
 
>1500件しか登録できないため
このイメージだと、インポートのような気がしますが・
 
 
ブック毎に処理するというのが仏なんですが、
>3つのブック
というのもよくわかりませんが?
 
コードの中に3つのブックが明示されていますか?
 
そもそも、このマクロは、3つのブックとどの様な関係になっているのか?
 
 
 

回答
投稿日時: 20/04/07 18:14:45
投稿者: simple

横から失礼。
worksheets(2)のデータを、1500行ずつ、新しいブックにコピーしたい、ということのようですが、
>よろしくお願いいたします。
とは、何をお願いしているのか、よくわかりません。
問題点があるなら、それを明示的に説明してください。

回答
投稿日時: 20/04/07 18:23:12
投稿者: mattuwan44

Option Explicit

Sub test()
    Dim wbkOld As Workbook          '送られてきたブック
    Dim strFullPath As String       '送られてきたファイルのフルパス
    Dim rngTitle As Range           'タイトル行のセル範囲
    Dim rngData As Range            'コピーするデータ範囲の基準位置セル
    Dim ixRow As Long               '行番号
    Const myNumber As Long = 1500   '1回に転記するデータ数

    '送られてきたブックフルパスを取得
    strFullPath = Application.GetOpenFilename()
    'ファイルを開く
    Set wbkOld = Workbooks.Open(strFullPath)
    'タイトル行セル範囲取得
    Set rngTitle = wbkOld.Worksheets(1).UsedRange.Resize(9)
    'データセル範囲基準位置
    Set rngData = rngTitle(10, 1)
    ixRow = 1

    'データが無くなるまで繰り返し
    Do Until Intersect(rngData.CurrentRegion, rngData(ixRow, 1)) Is Nothing
        'シートの初期化
        ThisWorkbook.Worksheets(1).UsedRange.ClearContents
        '1500件分コピペ
        Union(rngTitle, rngData(ixRow, 1).Resize(myNumber, rngTitle.Columns.Count)).Copy _
                ThisWorkbook.Worksheets(1).Range("A1")
        '新しいブックへシートをコピー
        ThisWorkbook.Worksheets(1).Copy
        '新しくできたブックの処理
        With Workbooks(Workbooks.Count)
            '名前を付けて保存
            .SaveAs Replace(wbkOld.Path, ".xlsx", "-" & ixRow & ".xlsx")
            '閉じる
            .Close False
        End With
        '次のデータの先頭位置
        ixRow = ixRow + myNumber
    Loop
End Sub

 
シート上のセルの位置をどうやって表現するかが肝ですね。
色んな書き方(言い方)が出来ると思うけどとりあえず、ぱっと思いついた感じ。
動作確認してないので、バグあったらごめんなさい。
参考になれば。

投稿日時: 20/04/08 10:53:19
投稿者: vaioyuki

WinArrowさん
いつもありがとうございます。
わかりにく説明で申し訳ありません。
ユーザーから送られてくるデータをこちらで修正して別ツールにインストールします。
こちらのExcelからは1500づつに分けてコピーして別ブックに保存するという意味合いでエクスポートという言葉を使いました。
 
3つのブックというのはユーザーから送られてくるデータが今までは多くて4000ほど、これを1500づつわけるとすると3つのブックになるなという意味合いです。
 
 
simpleさん
いつもありがとうございます。
今だと多くても3つ分のブックにしか分けられない、しかも3001以上になると1500を超えてもひとつのデータになってしまうので何データが来ても1500づつ分けられることができないかなと思い質問させていただきました。
 
 
mattuwan44さん
いつもありがとうございます。
私の説明が悪いのと知識不足が原因だと思うのですが、
送られてきたブックとファイルパスの使い方がいまいちわかってません。
元々送られてきたデータは別シートにそのままコピペしてそこで様々なメンテナンスを行っています。(正誤チェックのようなもの)
 

'データが無くなるまで繰り返し
    Do Until Intersect(rngData.CurrentRegion, rngData(ixRow, 1)) Is Nothing
        'シートの初期化
        ThisWorkbook.Worksheets(1).UsedRange.ClearContents
        '1500件分コピペ
        Union(rngTitle, rngData(ixRow, 1).Resize(myNumber, rngTitle.Columns.Count)).Copy _
                ThisWorkbook.Worksheets(1).Range("A1")
        '新しいブックへシートをコピー
        ThisWorkbook.Worksheets(1).Copy
        '新しくできたブックの処理
        With Workbooks(Workbooks.Count)
            '名前を付けて保存
            .SaveAs Replace(wbkOld.Path, ".xlsx", "-" & ixRow & ".xlsx")
            '閉じる
            .Close False
        End With
        '次のデータの先頭位置
        ixRow = ixRow + myNumber
    Loop

 
このあたりは私がしたかったことのような気がするので落ち着いて解読します。
 
 
またご報告させていただきます。

回答
投稿日時: 20/04/08 17:36:05
投稿者: simple

回答拝見しました。

引用:
今だと多くても3つ分のブックにしか分けられない、しかも3001以上になると1500を超えてもひとつのデータになってしまうので何データが来ても1500づつ分けられることができないかなと思い質問させていただきました。
今のものは、数の制約はあっても、その範囲内であれば、正常に動作しているんですか?
確認はされていますか?

投稿日時: 20/04/09 17:22:46
投稿者: vaioyuki

ありがとうございます。
 
いつも2605データでしていたのですが、倍の5210件でしてみたらブックは作られませんでした。。。

回答
投稿日時: 20/04/09 19:54:46
投稿者: mattuwan44

引用:
いつも2605データでしていたのですが、倍の5210件でしてみたらブックは作られませんでした。。。

 
あなたは解っていると思いますが、回答側ではあなたのパソコンは見れません。
 
どんなコードを実行したが、
「想定されるブック数が何個に対して、
何個しかブックが作られず、
何件のデータがコピーされただけ。」
などと説明してください。
 
ちなみに、データの中に空白行や空白列は含まれますか?
それによって対処の仕方がが違ってきますので。

投稿日時: 20/04/11 18:31:13
投稿者: vaioyuki

mattuwan44さん
 
ありがとうございます。
一番最初に質問させていただいたコードを実行したら2605データの時は2個ブックは作られましたが、
倍の5210件の時はひとつも作られませんでした。
 
空白列あります。
入力されていない項目もあります。
例えば得意先が1の場合は得意先住所が入力されていて0の場合は空白とか。
 
よろしくお願いします。

投稿日時: 20/04/16 10:11:59
投稿者: vaioyuki

いつもありがとうございます。
 
私には難しかったので、
 
Case Is <= 6000
 
で4つのブックまで対応という形にしたいと思います。
それ以上のデータある場合はまた増やしていきます。(^^;)
 
ありがとうございました。