| |
余りスマートとは言えませんが？
Sheet1には、列見出しが有る物とします
データは直接削除せず、新規Bookを作成し其処に集計したデータを転記します
尚、テキスト出力は、Csvの形で出力されます
Option Explicit
Public Sub Sample()
'元々のデータ列数（A列〜D列）
Const clngColumns As Long = 4
'「氏名」の有る列(基準セルからのA列の列Offset)
Const clngName As Long = 0
'「振込口座」の有る列(基準セルからのD列の列Offset)
Const clngAccount As Long = 3
'「支払い金額」の有る列(基準セルからのC列の列Offset)
Const clngPayment As Long = 2
'結果出力の先頭位置
Const cstrTop As String = "A1"
Dim i As Long
Dim lngPos As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntResult As Variant
Dim vntData As Variant
Dim dfn As Integer
Dim vntFile As Variant
Dim lngWrite As Long
Dim strProm As String
'Listの先頭セル位置を基準とする（「氏名」の列見出しのセル位置）
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'新規Bookの先頭シートの先頭セル位置を結果の基準位置とする
Set rngResult = Workbooks.Add.Worksheets(1).Cells(1, "A")
'Csv出力するファイル名を指定
vntFile = rngList.Parent.Parent.Name
lngPos = InStr(1, vntFile, ".", vbBinaryCompare)
vntFile = Left(vntFile, lngPos - 1)
If Not GetWriteFile(vntFile, ThisWorkbook.Path) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'画面更新を停止
Application.ScreenUpdating = False
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngName).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'復帰用整列Keyを作成
ReDim vntData(1 To lngRows, 1 To 1)
For i = 1 To lngRows
vntData(i, 1) = i
Next i
'復帰用Keyの出力
.Offset(1, clngColumns) _
.Resize(lngRows).Value = vntData
'データを「氏名」昇順の「振込口座」昇順で整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(, clngName), Order1:=xlAscending, _
Key2:=.Offset(, clngAccount), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
End With
'出力ファイルをOpen
dfn = FreeFile
Open vntFile For Output As dfn
'列見出しを配列に取得
vntResult = rngList.Resize(, clngColumns).Value
'列見出しをBookに出力
rngResult.Resize(, clngColumns).Value = vntResult
'列見出しをファイルに出力
Print #dfn, ComposeLine(vntResult)
With rngList
'データ先頭を配列に取得
vntResult = .Offset(1).Resize(, clngColumns).Value
'データ2行目〜最終行+1まで繰り返し
For i = 2 To lngRows + 1
'データを配列に取得
vntData = .Offset(i).Resize(, clngColumns).Value
'「氏名」若しくは「振込口座」が違った場合
If vntResult(1, clngName + 1) _
<> vntData(1, clngName + 1) _
Or vntResult(1, clngAccount + 1) _
<> vntData(1, clngAccount + 1) Then
'Bookの出力行を更新
lngWrite = lngWrite + 1
'データを転記
rngResult.Offset(lngWrite) _
.Resize(, clngColumns) = vntResult
'データをファイルに出力
Print #dfn, ComposeLine(vntResult)
'集計データを更新
vntResult = vntData
Else
'「支払い金額」を加算
vntResult(1, clngPayment + 1) _
= vntResult(1, clngPayment + 1) _
+ vntData(1, clngPayment + 1)
End If
Next i
End With
Close #dfn
With rngList
'元データを復帰
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'復帰用Key列を削除
.Offset(, clngColumns).EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function ComposeLine(vntField As Variant, _
Optional strDelim As String = ",") As String
' レコード作成
Dim i As Long
Dim strResult As String
Dim strField As String
Dim lngFieldEnd As Long
'データ数の取得
lngFieldEnd = UBound(vntField, 2)
'データ数繰り返し
For i = 1 To lngFieldEnd
strField = PrepareCsv2Field(vntField(1, i))
'結果変数にフィール文字列を加算
strResult = strResult & strField
'データカウントがデータ数未満の場合
If i < lngFieldEnd Then
'区切り文字を結果変数に加算
strResult = strResult & strDelim
End If
Next i
ComposeLine = strResult
End Function
Private Function PrepareCsv2Field(ByVal vntValue As Variant) As String
' Csv2出力形式の調整
Dim i As Long
Dim blnQuot As Boolean
Dim lngPos As Long
Const strQuot As String = """"
'引数の変数内部形式に就いて
Select Case VarType(vntValue)
Case vbString '文字列型
'ダブルクォーツの処理
i = 1
lngPos = InStr(i, vntValue, strQuot, vbBinaryCompare)
Do Until lngPos = 0
vntValue = Left(vntValue, lngPos) & Mid(vntValue, lngPos + 1)
i = lngPos + 2
lngPos = InStr(i, vntValue, strQuot, vbBinaryCompare)
Loop
'ダブルクォーツで括るか否かの判断処理
For i = 1 To 5
lngPos = InStr(1, vntValue, Choose(i, ",", strQuot, _
vbCr, vbLf, vbTab), vbBinaryCompare)
If lngPos <> 0 Then
blnQuot = True
Exit For
End If
Next i
'ダブルクォーツで括るの判断の場合
If blnQuot Then
vntValue = strQuot & vntValue & strQuot
End If
Case vbDate '日付型
'日付が時分秒を持つなら
If TimeValue(vntValue) > 0 Then
vntValue = Format(vntValue, "yyyy/mm/dd h:mm:ss")
Else
vntValue = Format(vntValue, "yyyy/mm/dd")
End If
End Select
PrepareCsv2Field = CStr(vntValue)
End Function
Private Function GetWriteFile(vntFileName As Variant, _
Optional strFilePath As String) As Boolean
Dim strFilter As String
Dim strInitialFile As String
'フィルタ文字列を作成
strFilter = "CSV File (*.csv),*.csv," _
& "Text File (*.txt),*.txt"
'既定値のファイル名を設定
strInitialFile = vntFileName
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'「ファイルを保存」ダイアログを表示
vntFileName _
= Application.GetSaveAsFilename(vntFileName, strFilter, 1)
If vntFileName = False Then
Exit Function
End If
GetWriteFile = True
End Function
|
|
Hirofumi
- 07/2/2(金) 23:53 -
