Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

4723 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

▼

【54944】１つのファイルを複数のCSVファイルにしたいのですが・・・ src 08/4/6(日) 1:14

【54945】Re:１つのファイルを複数のCSVファイルにし... Hirofumi 08/4/6(日) 8:12

【54946】Re:１つのファイルを複数のCSVファイルにし... src 08/4/6(日) 9:20

【54947】Re:１つのファイルを複数のCSVファイルにし... Hirofumi 08/4/6(日) 9:21

【54948】Re:１つのファイルを複数のCSVファイルにし... src 08/4/6(日) 10:01


	【54944】１つのファイルを複数のCSVファイルにし...

src - 08/4/6(日) 1:14 -


	引用なし

	パスワード

今、１つのファイルデータをマクロで、
複数のCSVファイルにしようと思っています。

WS_k(i, 1)が種別になってまして、これが変わったとき、
種別 + ”コード”という名前で保存しようと考えています。

自分なりに作ってみたのですが、
中身のデータが少なかったり、
10列まであるデータが5列位までしかなかったり、
書き方がどこか間違えているようです…。

どうすれば、よいのか、ご享受ください。
または、他の良い方法があれば、教えてください。
どうぞ、よろしくお願いいたします。

Sub データ作成()
　　Dim i　　 As Integer
　　Dim j　　 As Integer
　　Dim buf　 As String
　　Dim code　As String
　　
　　FileName1 = Workbooks(1).Path
　　FileName1 = FileName1 & "\コード.csv"

　　FileNum = FreeFile
　　Open FileName1 For Output As FileNum
　　
　　Set WS_k = Worksheets("商品シート").Cells
　　buf = ""
　　i = 1
　　code = WS_k(i, 1)
　　Do Until WS_k(i, 1) = ""

　　　　If code <> WS_k(i, 1) Then
　　　　　　Workbooks.Open Filename:=FileName1
　　　　　　ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & _
　　　　　　"\" & StrConv(code, vbWide + vbUpperCase) & "コード.csv"
　　　　　　ActiveWorkbook.Close
　　　　　　Close FileNum
　　　　　　FileNum = FreeFile
　　　　　　Open FileName1 For Output As FileNum
　　　　　　code = WS_k(i, 1)
　　　　End If
　　　　
　　　　For j = 1 To 10
　　　　　　buf = buf & Trim(WS_k(i, j)) & ","
　　　　Next j
　　　　Print #1, (buf)
　　　　buf = ""
　　　　i = i + 1
　　Loop
　　Close FileNum
End Sub


	【54945】Re:１つのファイルを複数のCSVファイルに...

Hirofumi - 08/4/6(日) 8:12 -


	引用なし

	パスワード

Option Explicit

Sub データ作成()

'　　Dim i　　 As Integer
'　　Dim j　　 As Integer
　　Dim i　　 As Long
　　Dim j　　 As Long
　　Dim buf　 As String
　　Dim code As String
　
　　'宣言の無い変数
　　Dim FileNum　As Integer
　　Dim FileName1　As String
　　Dim WS_k As Range '？
　　Dim strPath As String
　　
　　'出力ファイル名を設定
'　　FileName1 = Workbooks(1).Path
　　strPath = Workbooks(1).Path & "\"
'　　FileName1 = FileName1 & "\コード.csv"
　　FileName1 = "コード.csv"

　　'データ範囲を変数に取得
　　Set WS_k = Worksheets("商品シート").UsedRange
　　
　　'ファイルを出力モードでOpen
　　FileNum = FreeFile
'　　Open FileName1 For Output As FileNum
　　Open strPath & WS_k(1, 1).Value & FileName1 For Output As FileNum
　
　　'指定シートの全範囲を変数に取得？？？
'　　Set WS_k = Worksheets("商品シート").Cells
　　
'　　'バファをクリア
'　　buf = ""
　　'読み込み位置の初期値設定
　　i = 1
　　'読み込み位置の「種別」を変数codeに代入
'　　code = WS_k(i, 1)
　　code = WS_k(i, 1).Value
'　　Do Until WS_k(i, 1) = ""
　　Do Until WS_k(i, 1).Value = ""
　　　　'「種別」が変わったら
'　　　　If code <> WS_k(i, 1) Then
　　　　If code <> WS_k(i, 1).Value Then
'　　　　　　'出力ファイルをBookとして開く
'　　　　　　Workbooks.Open Filename:=FileName1
'　　　　　　　　'開いたBookを別名で保存
'　　　　　　　　ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path _
'　　　　　　　　　　　　& "\" & StrConv(code, vbWide + vbUpperCase) & "コード.csv"
'　　　　　　'開いたBookを閉じる
'　　　　　　ActiveWorkbook.Close
　　　　　　'出力ファイルをClose
　　　　　　Close FileNum
　　　　　　'ファイルを出力モードでOpen
　　　　　　FileNum = FreeFile
'　　　　　　Open FileName1 For Output As FileNum
　　　　　　Open strPath & WS_k(i, 1).Value & FileName1 For Output As FileNum
　　　　　　'読み込み位置の「種別」を変数codeに代入
'　　　　　　code = WS_k(i, 1)
　　　　　　code = WS_k(i, 1).Value
　　　　End If
　　　　'データを1レコード分（10フィールド）作成
　　　　'バファをクリア
　　　　buf = ""
'　　　　For j = 1 To 10
'　　　　　　buf = buf & Trim(WS_k(i, j)) & ","
'　　　　Next j
　　　　For j = 1 To WS_k.Columns.Count
　　　　　　If buf <> "" Then
　　　　　　　　buf = buf & ","
　　　　　　End If
　　　　　　buf = buf & Trim(WS_k(i, j).Value)
　　　　Next j
　　　　'データを出力
　　　　'何故、バファ番号が#1か？
　　　　'FileNumは？
'　　　　Print #1, (buf)
　　　　Print #FileNum, (buf)
'　　　　'バファをクリア
'　　　　buf = ""
　　　　'読み込み位置をインクリメント
　　　　i = i + 1
　　Loop
　　
　　'出力ファイルをClose
　　Close FileNum

　　Set WS_k = Nothing
　　
End Sub


	【54946】Re:１つのファイルを複数のCSVファイルに...

src - 08/4/6(日) 9:20 -


	引用なし

	パスワード

▼Hirofumi さまへ：

色々、コメント文をつけて解読していただきありがとうございます！
Hirofumi さまに頂いたもので、無事動きました。
４時間くらい悩んでいたのですが、もっと早く聴きに来ればよかったです。

本当にありがとうございました。

また、何かありましたら、よろしくお願いいたします。


	【54947】Re:１つのファイルを複数のCSVファイルに...

Hirofumi - 08/4/6(日) 9:21 -


	引用なし

	パスワード

「種別」が256種類以下であり、、「種別」が整列して居ない場合は、
こんなのでも、善いかも？

Sampleの条件として以下の様に設定します
　データの先頭はどのシートどの位置　→　"商品シート"のUsedRange先頭セル
　データが何列何行有るか　→　行数、列数は、Code先頭で取得
　データを全て配列に取得できるサイズなのか？
　　　→　1行づつ配列に取得
　Key「種別」がどの列に有るか　→　先頭列にある者とします
　Keyが整列されているか否か　→　整列がされていない物とする
　CSVは、文字列フィールドをダブルクォーツで括るか、否か
　　　→　括らない物とします
　出力ファイルを「種別」別に全てOpenして振り分ける
　　この場合、「種別」が多分256種類以下である必要有り

Public Sub Sample()

　　'「種別」の或る列位置(データ先頭位置からの列Offset：A列)
　　Const clngKey As Long = 0
　　
　　Dim i As Long
　　Dim j As Long
　　Dim strPath As String
　　Dim dfn As Integer
　　Dim strFileName As String
　　Dim strBuff As String
　　Dim vntKeys As Variant
　　Dim vntData As Variant
　　Dim rngList As Range
　　Dim lngRows As Long
　　Dim lngColumns As Long
　　Dim dicIndex As Object
　　Dim strProm As String
　　
　　'出力ファイル名を設定
　　strPath = Workbooks(1).Path & "\"
　　strFileName = "コード.csv"
　　
　　
　　With Worksheets("商品シート").UsedRange
　　　　'データ行数を取得
　　　　lngRows = .Rows.Count
　　　　'データ列数を取得
　　　　lngColumns = .Columns.Count
　　　　If lngRows <= 0 Then
　　　　　　strProm = "データが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'データ先頭位置を取得
　　　　Set rngList = .Cells(1, 1)
　　End With
　　　　
　　'「種別」列データを配列に取得
　　vntKeys = rngList.Offset(, clngKey).Resize(lngRows + 1).Value
　　
　　'Dictionaryオブジェクトを取得
　　Set dicIndex = CreateObject("Scripting.Dictionary")
　　
　　'結果を出力
　　With dicIndex
　　　　'データの先頭～最終まで繰り返し
　　　　For i = 1 To lngRows
　　　　　　'Dictionaryに登録がない場合
　　　　　　If Not .Exists(vntKeys(i, 1)) Then
　　　　　　　　'ファイル番号を採取
　　　　　　　　dfn = FreeFile
　　　　　　　　'採取してファイル番号で出力ファイルをOpen
　　　　　　　　Open strPath & vntKeys(i, 1) & strFileName _
　　　　　　　　　　　　　　For Output As dfn
　　　　　　　　'採取したファイル番号を登録
　　　　　　　　.Item(vntKeys(i, 1)) = dfn
　　　　　　End If
　　　　　　'1レコード分のデータを取得
　　　　　　vntData = rngList.Offset(i - 1).Resize(, lngColumns + 1).Value
　　　　　　'1レコード分の文字列を作成
　　　　　　strBuff = ""
　　　　　　For j = 1 To lngColumns
　　　　　　　　If strBuff <> "" Then
　　　　　　　　　　strBuff = strBuff & ","
　　　　　　　　End If
　　　　　　　　strBuff = strBuff & Trim(vntData(1, j))
　　　　　　Next j
　　　　　　'「種別」に対応するファイルに保存
　　　　　　dfn = .Item(vntKeys(i, 1))
　　　　　　Print #dfn, strBuff
　　　　Next i
　　End With
　　
　　'開いている全てのファイルをClose
　　Close
　　
　　strProm = "処理が終了しました"
　　
Wayout:

　　Set rngList = Nothing
　　Set dicIndex = Nothing
　　
　　MsgBox strProm, vbInformation
　　
End Sub


	【54948】Re:１つのファイルを複数のCSVファイルに...

src - 08/4/6(日) 10:01 -


	引用なし

	パスワード

▼Hirofumi さま：

実は「種別」が整列されていなかったのですが、
データを分割する前に、並び替えサブルーチンに飛ばしていました。

１つのことをするのにも色々な方法があるのですね。
自分はまだまだなので、これからもVBAを色々勉強していこうと思います。

Hirofumi さま
今回は、色々勉強になりました。
ありがとうございます。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

4723 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free