| |
「種別」が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
|
|
Hirofumi
- 08/4/6(日) 9:21 -
