Excel (VBA)

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

 
(Windows 10 Pro : Excel 2016)
指定列ごとにtxtファイルで保存したい
投稿日時: 18/11/16 08:17:59
投稿者: yukidosa

Excelの1つのシートに1行1件というレイアウトで、35000件程度のデータがあります。
こちらを2500件ずつtxtファイルで保存をしたい場合、どのようにVBAを記載すればよいのでしょうか?
 
35000件ちょうどではなく、25000件程度の時もあるし、30000件の時もあります。
 
26000件の場合、26001行目以降は何もデータが入りません。
 
何件であっても1つのVBAの実行でできるようにしたいのですが可能でしょうか?

回答
投稿日時: 18/11/16 09:45:00
投稿者: sk

引用:
Excelの1つのシートに1行1件というレイアウトで、
35000件程度のデータがあります。

・そのワークシートの 1 行目は列見出しとして使用されているのか。
 それとも列見出し行がなく、全てデータ行なのか。
 
引用:
こちらを2500件ずつtxtファイルで保存をしたい

・そのワークシートに列見出し行がある場合、
 出力される全てのテキストファイルに
 列見出し行を挿入する必要があるのか。
 
引用:
指定列ごとにtxtファイルで保存したい

・ここでの「指定列」とは具体的にワークシートの
 どこからどこまでの列を指しているのか。
 
・2 列以上のデータを 1 つのテキストファイルに
 出力する場合、列の区切り記号として
 どの文字を使用したいのか。
 (例えば CSV 形式ならカンマ( , )区切りとなる)
 
・また「指定列ごと」と記載されているが、
 例えばそのシートに 25000 行 × 3 列のデータ
 (列見出し行を除く)が格納されている場合、
 1 列ごとに 25000 / 2500 = 10 個のテキストファイルを
 作成する(最終的に 3 * 10 = 30 個のテキストファイルが
 作成される)という意味か。

回答
投稿日時: 18/11/16 13:00:34
投稿者: もこな2

タイトルは「指定列ごとにtxtファイルで保存したい」とのことですが、内容を拝見すると「1行1件というレイアウトで〜2500件ずつ」とのことですから、「指定ごとに」の書き誤りではないでしょうか
 
以下、指定行ごとと解釈した上での解答です・・・がその前に。
 
一度「Q&A 掲示板ご利用上のお願い」は目を通された方がよいとおもいます。

Q&A 掲示板ご利用上のお願い さんの引用:
禁止事項
コード制作依頼
「●●●を実行するようなマクロを作りたいのですが」「●●●をする方法を教えてください」といった、コード制作依頼ともとれるような質問はおやめください。

さて、お小言みたいなことだけいっても始まりませんのでとりあえずヒントを。
 
skさんも気にされていますが、1行目がタイトル行であって、毎回タイトル行は付けるたいのか、そうでないのかでも変わってきますけど、毎回付けるとするなら
 
1回目 → 1行目 & 2〜2501行目
2回目 → 1行目 & 2502〜5001行目


と繰り返していけばよいですね。
これを数学的に表現すると
 
n回目 → 1行目 & (((n-1)×2500)+2)行目 〜 (((n-1)×2500)+2501)行目
 
でしょうか。
このように整理してみると、nの部分に何日目かの数字を入れること (((n-1)×2500)+2)行目が、データの最終行を超える場合は実行する必要が無い(逆に言えば、全部のデータを処理するなら、データの終わりを超えるまで繰り返せばよい)ということがわかりますよね。
 
VBAの場合、繰り返し命令はいくつかありますが、今回はFor〜Nextステートメントというテクニックを使うと実現できるようにおもいますので、その路線で考えてみましょう。
 
昼休みがおわってしまったので続きはのちほど。

回答
投稿日時: 18/11/17 09:06:13
投稿者: simple

一定の行数単位で処理を行う部分について、説明をいただいています。
それを補足する意味で簡単な確認用コードを書きましたので、確認してみて下さい。
 

Sub test()
    Dim n As Long
    Dim m As Long
    Dim k As Long
    Dim numberOfGroups As Long
    Dim r1 As Long
    Dim r2 As Long
    
    n = 20      '全体の行数
'    n = 25     '別の前提(こちらについても確認してみてください)
    m = 10      '単位とする行数

    numberOfGroups = WorksheetFunction.Ceiling(n / m, 1)  'm行を単位とするグループの数
    
    For k = 1 To numberOfGroups
        r1 = 1 + (k - 1) * m
        r2 = WorksheetFunction.Min(n, k * m)
        ' 例えば Range(cells(r1,1),cells(r2,1)) を対象として作業します(列数は不明)
        Debug.Print r1; r2      '確認のためのデバッグ出力
    Next
End Sub

回答
投稿日時: 18/11/17 10:42:54
投稿者: もこな2

続き。
 
切り出すほうは、前述のとおり、決まった間隔ずらしながらループ処理すればよいとして、

yukidosa さんの引用:
txtファイルで保存をしたい場合
の方ですが、テキストファイルに書き出すという方法もありますが、簡単なのは"ブック"をテキスト形式で保存する方法だとおもいます。
 
なので、整理すると
引用:
(1)貼付先の新規ブックを用意する
 
(2)コピー元から貼付先に1行目 & (((n-1)×2500)+2)行目 〜 (((n-1)×2500)+2501)行目 をコピペする
 
(3)貼付先ブックをテキスト形式で保存する
 
(4)貼付先ブックを閉じる

これを、For〜Nextステートメントで繰り返せばよいでしょう。
このうち、新規ブックを用意(追加)、コピー、貼付、名前を付けて保存 あたりは、「マクロの記録」機能を使うと、どのような命令をつかえばよいのか調べることができますから、わからなければ手動操作を行ってマクロの記録をしてみてください。
 
とりあえず、上記までやってたたき台をつくってから、みなさんに添削を求めるようにすれば、コード作成依頼にはならないとおもいますし、答えも多数つくのではないかと思います。
 
※For〜Nextステートメントはマクロの記録では得られませんが、simpleさんが説明してくださっているので、研究してみてください。
 
長文失礼しました。

投稿日時: 18/11/19 16:23:09
投稿者: yukidosa

皆様ありがとうございました。
遅くなり申し訳ございません。
 
ネットなどで調べてまず、エクセルのデータをテキストデータにして
 
Sub @テキストデータでの出力()
'
' Macro1 Macro
'
 
'
    Sheets("変換シート").Select
    ActiveSheet.Range("$A$1:$AH$35002").AutoFilter Field:=4, Criteria1:= _
        "19000100"
    Cells.Select
    Selection.Delete Shift:=xlUp
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
  Application.DisplayAlerts = False
     
    ActiveWorkbook.SaveAs Filename:="c:\Users\ユーザー名\Desktop\事前チェック.txt", FileFormat:=xlText, CreateBackup:=False
     
    Application.DisplayAlerts = True
     
 
End Sub
 
テキストにした時点でタイトル行の1行目は削除しています。
これは一度全データでエラーがないことを確認するため、@だけを実行して保存をするものが欲しいからです。
 
元データでエラーを直したあと、再度@を実行。その後、2500件ずつにわけて他システムに読み込みます。
 
2500ずつのデータまではできたのですが、これをすると2500ずつのデータがエクセルでしかも開いたままになってしまいます。
1.2.3.4とかでも構わないので名前を付けてデスクトップに保存をしたい(できたら画面も閉じたい)のとタブ区切りのtextにしたいのですがどこに何を足したらいいのかわかりません。
 
 
 
Sub A2500ずつのデータ()
    Dim wb As Workbook
    Dim ts As Worksheet
    Dim x As Long, y As Long, i As Long, z As Long
    Set ts = ActiveSheet
    x = ts.UsedRange.Rows.Count
    y = Int(x / 2500) + IIf(x Mod 2500 > 0, 1, 0)
    z = ts.UsedRange.Rows(1).Row
    For i = 1 To y
        Set wb = Workbooks.Add
        wb.Sheets(1).Name = z & "〜" & z + 2499
        ts.Rows(z & ":" & z + 2499).Copy wb.Sheets(1).Range("A1")
        z = z + 2500
    Next i
 End Sub
 
よろしくお願いいたします。
 

回答
投稿日時: 18/11/19 17:48:18
投稿者: sk

引用:
テキストにした時点でタイトル行の1行目は削除しています。

引用:
タブ区切りのtextにしたい

(標準モジュール)
------------------------------------------------------------------
Option Explicit
 
Const RowsPerFile As Long = 2500
Const HeaderRow As Long = 0
 
Sub ExportTextFile()
     
    Dim wsSource As Excel.Worksheet
     
    Dim wbNewWorkBook As Excel.Workbook
    Dim wsNewWorksheet As Excel.Worksheet
     
    Dim rngHeader As Excel.Range
    Dim rngData As Excel.Range
     
    Dim lngFirstRow As Long
    Dim lngLastRow As Long
    Dim lngFileStartRow As Long
    Dim lngFileEndRow As Long
    Dim lngFileNumber As Long
     
    Dim strFolderPath As String
    Dim strNewFileName As String
     
    Set wsSource = ActiveSheet
     
    With wsSource.UsedRange
        If HeaderRow > 0 Then
            lngFirstRow = HeaderRow + 1
            Set rngHeader = .Range(.Cells(HeaderRow, 1), _
                                   .Cells(HeaderRow, .Columns.Count))
        Else
            lngFirstRow = 1
        End If
        lngLastRow = .Rows.Count
        lngFileNumber = 0
        strFolderPath = ThisWorkbook.Path & _
                        "\TextFiles_" & _
                        Format(Now(), "yyyymmddhhnnss")
         
        If Dir(strFolderPath, vbDirectory) = "" Then
            MkDir strFolderPath
        End If
         
        For lngFileStartRow = lngFirstRow To lngLastRow Step RowsPerFile
            lngFileEndRow = lngFileStartRow + RowsPerFile - 1
            If lngFileEndRow > lngLastRow Then
                lngFileEndRow = lngLastRow
            End If
            Set rngData = .Range(.Cells(lngFileStartRow, 1), _
                                 .Cells(lngFileEndRow, .Columns.Count))
             
            Set wbNewWorkBook = Workbooks.Add
            Set wsNewWorksheet = wbNewWorkBook.Worksheets(1)
                         
            If Not rngHeader Is Nothing Then
                rngHeader.Copy wsNewWorksheet.Cells(1, 1)
            End If
            rngData.Copy wsNewWorksheet.Cells(2 + (rngHeader Is Nothing), 1)
                         
            lngFileNumber = lngFileNumber + 1
            strNewFileName = strFolderPath & _
                             "\file_" & Format(lngFileNumber, "00000") & ".txt"
                         
            wbNewWorkBook.SaveAs Filename:=strNewFileName, _
                                 FileFormat:=xlCurrentPlatformText
             
            Set wsNewWorksheet = Nothing
            wbNewWorkBook.Close False
            Set wbNewWorkBook = Nothing
            Set rngData = Nothing
        Next
    End With
         
    Set rngHeader = Nothing
    Set wsSource = Nothing
     
    Shell "explorer.exe """ & strFolderPath & """", vbMaximizedFocus
         
End Sub
------------------------------------------------------------------
 
以上のようなコードを実行なさればよろしいのではないかと。

回答
投稿日時: 18/11/20 01:29:57
投稿者: もこな2

う〜ん。とりあえず

yukidosa さんの引用:
しかも開いたままになってしまいます。
名前を付けてデスクトップに保存をしたい(できたら画面も閉じたい)のとタブ区切りのtextにしたいのですがどこに何を足したらいいのかわかりません。

これは、
もこな2 さんの引用:
(3)貼付先ブックをテキスト形式で保存する
(4)貼付先ブックを閉じる
 
名前を付けて保存 あたりは、「マクロの記録」機能を使うと、どのような命令をつかえばよいのか調べることができます。
と、書いたつもりだったんだけど。。。
 
私が見る限り、ほぼ完成に近づいているのでもう少し頑張ってみましょう。
一応、完成形の一例を提示しておきます。
Sub さんぷる()
    Const tmp As Long = 2500
    Dim MyRNG As Range
    Dim i As Long
   
    With ActiveSheet.UsedRange
        For i = 1 To .Rows.Count Step tmp
            Set MyRNG = .Rows(i & ":" & i + (tmp - 1))
            
            With Workbooks.Add
                MyRNG.Copy .Sheets(1).Range("A1")
                
                Application.DisplayAlerts = False
                .SaveAs _
                    Filename:="c:\Users\ユーザー名\Desktop\" & i & "〜" & i + (tmp - 1), _
                    FileFormat:=xlText
                .Close
                Application.DisplayAlerts = True
            End With
        Next i
    End With

 End Sub

ファイル名について最後のものは端数が出る場合、中身とファイル名が一致しなくなるので、そこにこだわりがある場合、ちょっと一工夫いりますね。
ヒント:Min関数

投稿日時: 18/11/20 11:34:20
投稿者: yukidosa

皆様ありがとうございました。
ご指示いただいたものをあれこれ組み合わせてなんとか作成することができました。