| |
一応コンなので加算出きると思います
エクセル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)
'ファイルから１行読み込み
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
|
|
Hirofumi
- 05/9/26(月) 21:22 -
