[[20190322094455]] 『【マクロ】分割して別ブックに保存』(もずく) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『【マクロ】分割して別ブックに保存』(もずく)

度々すいません。
ネットで似ている物を読んでいるのですが、出来なくて。。

〜A列でフィルターし分割して別ブックに保存〜
■対象ブック:CSV修正.xlsmに入力したB1 & B2のCSV
Set ws = Workbooks("CSV修正.xlsm").Sheets("Sheet1")
ws.Range("B1") & "\" & "完成" & "\" & ws.Range("B2").Value & ".csv"

■対象ブックの中身(行数も列数もいっぱいあります)
     A列    B列    C列…
1行目   1     1     1
2行目   1     2     1
3行目   1     3     1
4行目   2     1     1   
5行目   3     1     1  
6行目   3     2     1   
7行目   3     3     1   
8行目   4     1     1 

■保存ファイル名
ws.Range("B2")に入力した値 _ A列の数字

■保存先:対象ブックと同じ格納先
元ブックは削除して大丈夫です。

宜しくお願い致します。

< 使用 Excel:Excel2016、使用 OS:Windows10 >


 A列でフィルターするのに固有のKeyが必要なので、、
 A列をディクショナリーで1回なめるか、、または、、
 A列を別の場所にコピーして重複の削除でユニークなKeyにして

 出来たKeyで順番にフィルターしていけばいい様に思います。。。けど?

 すみません。ヒントだけで、、、
(SoulMan) 2019/03/22(金) 10:57

SoulManさんありがとうございます。
ですが、ちょっと分からないのでネットで拾ったこちらを私が使用できるようにするにはどうすればいいでしょうか?
途中まで修正してるんですが、もう無理です。。
Sub CSV分割()

    Dim wkSh As Worksheet
    Dim wkCol As Long
    Dim myList As Range
    Dim wkR As Range
    Dim c As Range
    Dim myPath As String
    Dim ws As Worksheet
    'Dim wb As Workbooks

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set ws = Workbooks("CSV修正.xlsm").Sheets("Sheet1")

    myPath = ws.Range("B1") & "\" & "完成" & "\" & ws.Range("B2").Value & ".csv" & "\" & ws.Range("B2").Value & ".csv" '保存フォルダ名 適切なものに変更
    Worksheets.Add after:=Worksheets(Worksheets.Count)  'ブックの末尾に作業シートを
    Set wkSh = ActiveSheet

    With Worksheets(ws.Range("B1") & "\" & Range("B2"), Range("B2").Value)   'シート名は「wsのB2に入力されている値です」★ここで今つまづいてます。
        .Cells.Copy
        wkSh.Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            Set myList = .Range("A1").CurrentRegion
            wkCol = myList.Columns.Count + 2 'リスト領域の右、1列間をあけて作業域に
            'A列から一意の値を抽出し作業列に
            myList.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
                    CopyToRange:=.Cells(1, wkCol), Unique:=True
            With .Cells(1, wkCol).CurrentRegion  '抽出した領域全体
                Set wkR = .Offset(1).Resize(.Rows.Count - 1) 'その中の項目ラベル以外
            End With
            .Cells(1, wkCol + 1).Value = .Cells(1, wkCol).Value '検索ラベル

            For Each c In wkR  '抽出項目を1つずつ取り出す
                .Cells(2, wkCol + 1).Value = "=""" & c.Value & """"
                '作業用シートの値をクリア
                wkSh.Cells.ClearContents
                '作業用シートに絞り込んだデータを抽出
                myList.AdvancedFilter Action:=xlFilterCopy, _
                    CriteriaRange:=.Cells(1, wkCol + 1).Resize(2), _
                    CopyToRange:=wkSh.Range("A1"), Unique:=False
                '作業用シートのみの新規ブックを作成
                wkSh.Copy
                'そのブックを、取り出した値をブック名にして保存
                '同名のブックが存在してもワーニングなしで上書き
                ActiveWorkbook.SaveAs myPath & c.Value & ".xls"
                ActiveWorkbook.Close savechanges:=False
            Next

            .Columns(wkCol).Resize(, 2).Clear   '作業列のクリア

    End With

    wkSh.Delete  '作業用シートの削除
    Set wkR = Nothing
    Set myList = Nothing

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox "処理が終了しました"

End Sub
(もずく) 2019/03/22(金) 15:59


 こんにちは。

 なにをどうしようとしているのか、よくわかんないです。

 CSV修正.xlsmというブックの最初のシートには、以下のデータが入っているわけですね。

      A列    B列    C列… 
 1行目   1     1     1 
 2行目   1     2     1 
 3行目   1     3     1 
 4行目   2     1     1    
 5行目   3     1     1   
 6行目   3     2     1    
 7行目   3     3     1    
 8行目   4     1     1

 で、 
 (1) CSV修正.xlsm と同じフォルダに、
 (2) ws.Range("B1") という名前のサブフォルダをつくって、
 (3) さらに、 "完成"  という名前のサブフォルダをつくって、
 (4)  ws.Range("B2").Value & ".csv" という、CSVファイルを保存するのですか?

 でも、このようにも書いてあります。
 >■保存ファイル名 
 > ws.Range("B2")に入力した値 _ A列の数字 

 質問の内容が、最初の書き込みの中で矛盾しちゃっているので、よくわかりません。

 そのCSVファイルには、どのようなデータが保存されていればいいのですか?

(でれすけ) 2019/03/22(金) 16:22


すいません。書き直しますね。
(1) "完成"フォルダにある CSV修正.xlsm のマクロを実行し、
(2) CSV修正.xlsmに記載されているパス(B1のセル)とフォルダ名(B2のセル)のCSV(C:temp\1号機.csv)を
マクロでA列を元に別ブックに分割し、
(3) 同じ "完成" フォルダに格納。
(4) 分割したファイル名はCSV修正.xlsmに記載されている「フォルダ名(B2のセル)」と「_」とCSVの「A列の値」にする

因みにCSV修正.xlsmの中はこんな感じです
■CSV修正.xlsm---------
A列       B列
格納先     C:temp
フォルダ名   1号機


出力するCSVの完成系はこちらです。
■C:temp\1号機_1.csv

           A列    B列    C列…
1行目   1     1     1
2行目   1     2     1
3行目   1     3     1 

■C:temp\1号機_2.csv

           A列    B列    C列…
1行目   2     1     1    

■C:temp\1号機_3.csv

           A列    B列    C列…
1行目   3     1     1  
2行目   3     2     1   
3行目   3     3     1    
(もずく) 2019/03/22(金) 16:54

 理解しました。
 
 以下、確認です

 (1) 読み込むCSVファイルには、列タイトル行はないのでしょうか。
     ないとすると、ひと手間かける必要があります。
       フィルタをかける時に列タイトルを付与する。→書き込むときに列タイトルを除く

 (2) A列に値は、何種類ぐらい想定されますか?
       新規で書き出すCSVファイル数といってもいいです。
  
 (3) マクロの仕様としてCSVファイルをExcelで「開く」必要ありますか。
       CSVファイルをブックとして開くとか、シートに展開するとかしないでも出来るように思います。

 でわ
(でれすけ) 2019/03/22(金) 17:16

(1)列タイトルは含まれてます。ので気にしなくて大丈夫です。

(2)元が4万500行ほど、列は150ほどです。
分割後は1500行ほどに

(3)開く必要はないかと思います。

(もずく) 2019/03/22(金) 17:32


 (2)はユニークなA列の値は何個かって教えて欲しかったのですが。

 元が45000行で1ファイル1500行くらいだと、分割後のファイルは高々 30ファイル程度と思っていいですか

(でれすけ) 2019/03/22(金) 17:38


 エラー処理等やってませんので、ご了承ください。

 Sub SplitCSV()

  Dim CSVPath As String, BaseName As String, inFIle As Integer
  Dim Lbuf As String, columnTitle As String, key As String
  Dim outFiles As Object

  '== 元ファイルの情報を取得 ===
  With ThisWorkbook.Worksheets(1)
     CSVPath = .Range("B1").Value & "\" & .Range("B2").Value & ".csv"
  End With
  If Dir(CSVPath) = "" Then MsgBox CSVPath & "が見つかりません", vbCritical: Exit Sub
  BaseName = Split(CSVPath, "\")(UBound(Split(CSVPath, "\")))
  BaseName = Left(BaseName, Len(BaseName) - 4)
  '== 元ファイルの情報を取得 ===

  Set outFiles = CreateObject("Scripting.Dictionary")

  inFIle = FreeFile
  Open CSVPath For Input As inFIle

  Line Input #inFIle, columnTitle
  Do While Not EOF(inFIle)
     Line Input #inFIle, Lbuf
     key = Trim(Split(Lbuf, ",")(0))
     If Not outFiles.Exists(key) Then
        outFiles(key) = FreeFile
        Open ThisWorkbook.Path & "\" & BaseName & "_" & key & ".csv" For Output As outFiles(key)
        Print #outFiles(key), columnTitle
     End If
     Print #outFiles(key), Lbuf
  Loop

  Close
  Set outFiles = Nothing

 End Sub

 でわ
(でれすけ) 2019/03/22(金) 18:13

 あれ? 分割したCSVファルの保存フォルダがなんか違う?

 その辺は、調整してください。

(でれすけ) 2019/03/22(金) 18:42


すいません。。
調整できませんでした。

ファイル名または番号が不正と出るんですが、どこが違うのかわからないです。
Open ThisWorkbook.Path & "\" & BaseName & "_" & key & ".csv" For Output As outFiles(key)
(もずく) 2019/03/25(月) 16:17


 コピペしてそのまま実行してますか?
 どこか修正してるなら、修正後のコードを書いてください。

 それと、デバックモードになったら、ローカルウィンドウを表示させて、
 変数 BaseName と Key の値が何になっているか確認して教えてください。

(でれすけ) 2019/03/25(月) 16:38


コピペしてます。

BaseName⇒B1のセルの値(こっちは問題ないと思います)
Key⇒"Serial number : 39157(VSP G1000/G1500 and VSP F1500)"

(もずく) 2019/03/25(月) 17:27


 Keyは、元のCSVファイルのA列の値が入るように組んでますが、
 > Key⇒"Serial number : 39157(VSP G1000/G1500 and VSP F1500)" 
 間違いなくA列の値がはいってますか?

 それであれば、A列の値にコロン入っているが問題です。

 Windowsでは、ファイル名に使えない文字というのがありまして、
 詳しくは検索してください。
(でれすけ) 2019/03/25(月) 17:42

出来ました!!ありがとうございます。
原因は作業先のフォルダ名の「完成」が抜けていました。
申し訳ございません。
(もずく) 2019/03/26(火) 09:25

追加ですいません。。
不要な行削除のマクロボタンを作成するのですが、教えて下さい。

今フォルダには下記CSVがあるのですが、こちらを削除、修正したいです。
【C:temp\1号機.csv】パス(B1のセル)とフォルダ名(B2のセル)←削除
【C:temp\1号機_1.csv】←1行目とA列の削除
【C:temp\1号機_2.csv】←A列の削除
【C:temp\1号機_3.csv】←A列の削除

こんな感じと思います。
(1)【C:temp\1号機.csv】を削除
CSVPath = .Range("B1").Value & "\" & "完成" & "\" & .Range("B2").Value & ".csv"
Kill CSVPath
(2)1号機( .Range("B2").Value)で検索し
(3)末尾が_1の場合は、1行目とA列の削除
(4)末尾が_1以外の場合または2以上は、A列の削除

申し訳ございませんが宜しくお願いします。
(もずく) 2019/03/26(火) 10:24


 最初からA列を書き込まなきゃいいのでは。

 >末尾が_1の場合は、1行目とA列の削除
 1行目って、列タイトル行のことでしょうか。
(でれすけ) 2019/03/26(火) 11:11

分割用の採番をA列にしてるんです。
抜けがないかの確認で。

末尾が_1の場合は、1行目とA列の削除 1行目って、列タイトル行のことでしょうか。 ⇒すいません。間違えました。申し訳ございません。
(3)末尾が_1の場合は、A列の削除
(4)末尾が_1以外の場合または2以上は、1行目とA列の削除

末尾が_1は1行目の列タイトル行は必要でしたが、
末尾が_2からは1行目は不要です。
(もずく) 2019/03/26(火) 12:01


 なんかかみ合わないな...

 >分割用の採番をA列にしてるんです。
 それは知っています。

 分割して書き出したCSVを目視で確認してからA列を削除するのでしょうか。
 目視で確認するなら、その時に手作業で削除すればいいでしょう。

 目視での確認が不要なら、分割したCSVファイルを書き出す時に、
 A列を書き出さないようにすればいいでしょう。

 タイトル行も同じ。不要なら書き出すのを止めればいい。
(でれすけ) 2019/03/26(火) 12:10

 Sub SplitCSV()

  Dim CSVPath As String, BaseName As String, inFIle As Integer
  Dim Lbuf As String, columnTitle As String, key As String
  Dim outFiles As Object

  '== 元ファイルの情報を取得 ===
  With ThisWorkbook.Worksheets(1)
     CSVPath = .Range("B1").Value & "\" & .Range("B2").Value & ".csv"
  End With
  If Dir(CSVPath) = "" Then MsgBox CSVPath & "が見つかりません", vbCritical: Exit Sub
  BaseName = Split(CSVPath, "\")(UBound(Split(CSVPath, "\")))
  BaseName = Left(BaseName, Len(BaseName) - 4)

  Set outFiles = CreateObject("Scripting.Dictionary")

  inFIle = FreeFile
  Open CSVPath For Input As inFIle
  Line Input #inFIle, columnTitle
  columnTitle = Mid(columnTitle, InStr(columnTitle, ",") + 1)  '修正
  Do While Not EOF(inFIle)
     Line Input #inFIle, Lbuf
     key = Trim(Split(Lbuf, ",")(0))
     Lbuf = Mid(Lbuf, InStr(Lbuf, ",") + 1)    '修正
     If Not outFiles.Exists(key) Then
        outFiles(key) = FreeFile
        Open ThisWorkbook.Path & "\" & BaseName & "_" & key & ".csv" For Output As outFiles(key)
        If key = "1" Then Print #outFiles(key), columnTitle  '修正
     End If
     Print #outFiles(key), Lbuf
  Loop
  Close

  Set outFiles = Nothing

 End Sub 
(でれすけ) 2019/03/26(火) 12:35

出来ました!!
これで完了です。
ありがとうございます。
(もずく) 2019/03/26(火) 13:09

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.