Excel VBA質問箱 IV

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

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


52414 / 76732 ←次へ | 前へ→

【29157】Re:CSVのデータを加算していく方法について
回答  Hirofumi  - 05/9/26(月) 21:22 -

引用なし
パスワード
   一応コンなので加算出きると思います

エクセルBookは、

  A    B    C
1  店   りんご  みかん
2 A店    0     1
3 B店    1     1
4 C店    1     2
5 D店    1     0

で、店名は、昇順に並べられて居る物とします

Csvファイルは、

店,りんご,みかん
A店 , 2, 1
C店 , 1, 0
D店 , 1, 1

の形で、列見だしが(Headerが)有る物とします

Option Explicit

Public Sub CrossTabulation()

  '果物名の有る列数
  Const clngColumns As Long = 2
  
  Dim i As Long
  Dim strPath As String
  Dim dfn As Integer
  Dim vntFileName As Variant
  Dim strBuff As String
  Dim vntField As Variant
  Dim vntData As Variant
  Dim lngRow As Long
  Dim rngStores As Range
  Dim rngResult As Range
  Dim blnHeader As Boolean
  Dim strProm As String
  
  'Textファイルの有るフォルダを指定
'  strPath = "E:\Office2000\Excel\Test5\A"

  '読み込むファイルを取得(ダイアログ表示し、其処から選択)
  If Not GetReadFile(vntFileName, strPath, False) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(1, "A")
  With rngResult
    '店名が有る行数を取得
    lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
    '店名が有る範囲を取得
    If lngRow > 0 Then
      Set rngStores = .Offset(1).Resize(lngRow)
    End If
  End With

  '指定されたファイルをOpen
  dfn = FreeFile
  Open vntFileName For Input As dfn
  
  'ヘッダFlagをTrueに(ヘッダ行、1行読み飛ばす場合)
  'ヘッダ行が無いならここをFalseにする
  blnHeader = True
  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'ヘッダ行、1行読み飛ばし
    If Not blnHeader Then
      'フィールドに分割
      vntField = Split(strBuff, ",", , vbBinaryCompare)
      '店名を探索(店名が無ければ、行挿入を行い店名を記述
      lngRow = GetStoresRow(vntField(0), rngStores, rngResult)
      '店名の有る行に加算
      With rngResult
        '果物範囲のデータを配列に取得
        vntData = .Offset(lngRow, 1).Resize(, clngColumns).Value
        'Csvの値を加算
        For i = 1 To clngColumns
          vntData(1, i) = vntData(1, i) + Val(vntField(i))
        Next i
        '果物範囲に配列うぃ出力
        .Offset(lngRow, 1).Resize(, clngColumns).Value = vntData
      End With
    Else
      'ヘッダFlagをFalseに
      blnHeader = False
    End If
  Loop
  
  Close #dfn

  strProm = "処理が完了しました"
  
Wayout:

  Application.ScreenUpdating = True

  Set rngStores = Nothing
  Set rngResult = Nothing

  Beep
  MsgBox strProm

End Sub

Private Function GetStoresRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Long
  Dim lngOver As Long
  Dim lngCount As Long

  '店名範囲に店名が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
    lngOver = 1
  Else
    '店名を探索
    lngFound = DataSearch(vntTagNo, rngScope, lngOver)
    lngCount = rngScope.Rows.Count
  End If

  '探索成功(店名が有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetStoresRow = lngFound
  Else
    With rngListTop
      '挿入位置が行末で無いなら
      If lngOver <= lngCount Then
        '行を挿入
        .Offset(lngOver).EntireRow.Insert
      End If
      'セルの書式を文字列に設定
'      .Offset(lngOver).NumberFormatLocal = "@"
      '店名を書き込み
      .Offset(lngOver).Value = vntTagNo
      '挿入位置を返す
      GetStoresRow = lngOver
      '探索範囲の更新
      Set rngScope _
        = .Offset(1).Resize(lngCount + 1)
    End With
  End If

End Function

Private Function DataSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long, _
            Optional lngMode As Long = 1) As Long

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, lngMode)
  lngOver = 1
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      DataSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  End If

End Function

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames & "{TAB}", False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function
0 hits

【29134】CSVのデータを加算していく方法について ピンキー 05/9/26(月) 14:28 質問
【29141】Re:CSVのデータを加算していく方法について Jaka 05/9/26(月) 17:11 回答
【29148】Re:CSVのデータを加算していく方法について ピンキー 05/9/26(月) 17:38 発言
【29157】Re:CSVのデータを加算していく方法について Hirofumi 05/9/26(月) 21:22 回答
【29160】Re:CSVのデータを加算していく方法について だるま 05/9/26(月) 22:37 回答
【29230】Re:CSVのデータを加算していく方法について ピンキー 05/9/28(水) 15:03 発言
【29243】Re:CSVのデータを加算していく方法について だるま 05/9/28(水) 19:39 回答
【29278】Re:CSVのデータを加算していく方法について ピンキー 05/9/29(木) 14:30 お礼

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