Excel VBA質問箱 IV

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

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


27109 / 76732 ←次へ | 前へ→

【54947】Re:1つのファイルを複数の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
0 hits

【54944】1つのファイルを複数のCSVファイルにしたいのですが・・・ src 08/4/6(日) 1:14 質問
【54945】Re:1つのファイルを複数のCSVファイルにし... Hirofumi 08/4/6(日) 8:12 回答
【54946】Re:1つのファイルを複数のCSVファイルにし... src 08/4/6(日) 9:20 お礼
【54947】Re:1つのファイルを複数のCSVファイルにし... Hirofumi 08/4/6(日) 9:21 回答
【54948】Re:1つのファイルを複数のCSVファイルにし... src 08/4/6(日) 10:01 お礼

27109 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free