Excel VBA質問箱 IV

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

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


6237 / 13644 ツリー ←次へ | 前へ→

【46426】重複データの加工について one-x 07/2/2(金) 20:39 質問[未読]
【46427】Re:重複データの加工について とおりすがり 07/2/2(金) 21:22 発言[未読]
【46428】Re:重複データの加工について かみちゃん 07/2/2(金) 22:17 発言[未読]
【46429】Re:重複データの加工について ponpon 07/2/2(金) 23:30 発言[未読]
【46430】Re:重複データの加工について Hirofumi 07/2/2(金) 23:53 回答[未読]
【46433】Re:重複データの加工について one-x 07/2/3(土) 11:41 お礼[未読]

【46426】重複データの加工について
質問  one-x  - 07/2/2(金) 20:39 -

引用なし
パスワード
   初投稿です。
会社で経理担当をしていますが、エクセルにより支払いデータを管理しています。
フィールドは、A氏名・B住所・C支払い金額・D振込口座とします。
このうち、氏名と振込口座が重複する場合、支払い金額を合計して一本のレコードにしてから重複削除して、テキストファイル保存したいのですが、VBAでスマートに記述するには、どうしたら良いでしょうか。(単なる重複削除ではありません)
なんとか、よろしくお願いします。

【46427】Re:重複データの加工について
発言  とおりすがり  - 07/2/2(金) 21:22 -

引用なし
パスワード
   >VBAでスマートに記述するには、どうしたら良いでしょうか。

VBAを一生懸命勉強してテクニックを身につけるしかありませ
んね。

【46428】Re:重複データの加工について
発言  かみちゃん  - 07/2/2(金) 22:17 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>なんとか、よろしくお願いします。

http://www2.moug.net/bbs/exvba/20070202000045.htm
で解決されたようです。

【46429】Re:重複データの加工について
発言  ponpon  - 07/2/2(金) 23:30 -

引用なし
パスワード
   dictionaryの練習に作ってみました。
sheet1に
    A    B    C    D
1    氏名    住所    支払い金額    振込口座
2    A    福岡県    20000    000123456
3    B    大分県    30000    002345678
4    C    佐賀県    30000    003456789
5    D    北海道    50000    005677821
6    A    福岡県    40000    000123456
7    E    東京都    20000    009876532
8    B    大分県    10000    002345678
9    F    静岡県    20000    000435621
10    A    福岡県    20000    000123456
11    G    新潟県    70000    000986789
12    A    福岡県    20000    000123456
13    H    福島県    30000    009684522
14    I    三重県    40000    056783423
15    D    北海道    50000    005677821
16    J    愛媛県    10000    000243627
17    D    北海道    50000    005677821
18    K    秋田県    10000    024246457
19    E    東京都    20000    009876532
20    L    広島県    35000    057645784
21    M    大阪府    28000    056457358
22    E    東京都    20000    009876532

このようなデータがあるとして
結果は
    A    B    C    D
1    氏名    住所    支払い金額    振込口座
2    A    福岡県    100000    000123456
3    B    大分県    40000    002345678
4    C    佐賀県    30000    003456789
5    D    北海道    150000    005677821
6    E    東京都    60000    009876532
7    F    静岡県    20000    000435621
8    G    新潟県    70000    000986789
9    H    福島県    30000    009684522
10    I    三重県    40000    056783423
11    J    愛媛県    10000    000243627
12    K    秋田県    10000    024246457
13    L    広島県    35000    057645784
14    M    大阪府    28000    056457358

のような感じになります。
コードは、
Sub test()
  Dim myDic As Object
  Dim myR As Range, r As Range
  Dim myVal As Variant
  Dim myAry(3) As Variant
  
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    myVal = .Range("A1").Resize(, 4).Value
    Set myDic = CreateObject("Scripting.Dictionary")
    Set myR = .Range("A2", .Range("A65536").End(xlUp))
    
    For Each r In myR
      If Not myDic.Exists(r.Value & r.Offset(, 3).Value) Then
       myAry(0) = r.Value
       myAry(1) = r.Offset(, 1).Value
       myAry(2) = r.Offset(, 2).Value
       myAry(3) = r.Offset(, 3).Value
       myDic(r.Value & r.Offset(, 3).Value) = myAry
      Else
       myAry(0) = r.Value
       myAry(1) = r.Offset(, 1).Value
       myAry(2) = myDic(r.Value & r.Offset(, 3).Value)(2) + r.Offset(, 2).Value
       myAry(3) = r.Offset(, 3).Value
       myDic(r.Value & r.Offset(, 3).Value) = myAry
      End If
    Next
    .Cells.ClearContents
    With .Range("A1")
      .Resize(, 4).Value = myVal
      .Offset(1).Resize(myDic.Count, 4).Value = _
      Application.Transpose(Application.Transpose(myDic.items))
    End With
  End With
  Application.ScreenUpdating = True
  Set myDic = Nothing
End Sub

"Scripting.Dictionary"で過去ログを検索すれば、いろいろ出てくると思います。
参考になればよいのですが・

【46430】Re:重複データの加工について
回答  Hirofumi  - 07/2/2(金) 23:53 -

引用なし
パスワード
   余りスマートとは言えませんが?
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

【46433】Re:重複データの加工について
お礼  one-x  - 07/2/3(土) 11:41 -

引用なし
パスワード
   ponponさん、 Hirofumiさん、ありがとうございます!
まさか、あの短時間でこんなに素晴らしい回答をいただけるとは・・・。
dictionaryは、まったく分かりませんでしたがこれで勉強になりました。
新規Bookを作成し集計データを転記するというのも、いろいろ応用がききそうです。
お二人のご好意を無駄にすることのないよう、がんばりたいと思います。
また、ネチケットについて無知であったことは、恥ずかしく思い、今後ご迷惑をおかけしないよう心がけるつもりです。
本当にありがとうございました。

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