Excel VBA質問箱 IV

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

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


23435 / 76732 ←次へ | 前へ→

【58663】Re:同じ文字列の検索
発言  kanabun  - 08/11/3(月) 22:33 -

引用なし
パスワード
   なんだかマルチポストをされると、回答する気が失せますね

Sub Try3() と Sub Try_Dic()のグループ別集計作業を
ドッキングさせたものを投稿して、ぼくの発言はこれにて
終了させていただきます。


Sub Try4c()
  Dim WS1 As Worksheet
  Dim ColA As Range, c As Range
  Dim v, u, w, key
  Dim ss As String, sss As String
  Dim i As Long, ii As Long, j As Long, n As Long
  Dim total As Double
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set WS1 = Worksheets("Anoth") '------- 集計元データシート
  Set ColA = WS1.Range("A2", WS1.Cells(Rows.Count, 1).End(xlUp))
  WS1.Columns("C:D").Insert
  With ColA.Columns(3)
    .Formula = "=ROW()"
    .Value = .Value
  End With
  ColA.Columns(4).FormulaR1C1 = "=LEN(RC[-3])"
  With ColA.Resize(, 4)
    .Sort Key1:=.Columns(4), Header:=xlNo
    v = Application.Transpose(.Columns(1))
    u = Application.Transpose(.Columns(2))
    .Sort Key1:=.Columns(3), Header:=xlNo
  End With
  WS1.Columns("C:D").Delete
  
  For i = 1 To UBound(v)
    ss = v(i)
    If dic.Exists(ss) Then
      Do
        ss = ss & " "
      Loop While dic.Exists(ss)
      v(i) = ss
    End If
    dic(ss) = u(i)
    If Not IsNumeric(ss) Then
      If InStr("01", Left$(ss, 1)) Then ss = Mid$(ss, 2)
    End If
    
    If Len(ss) > 10 Then ss = Left$(ss, 10)
    Distribute sss, ss
  Next
  
  u = Split(Left$(sss, Len(sss) - 1), "|")
  n = dic.Count + UBound(u) + 1
  ReDim tbl(n, 1 To 3)
  i = 0
  tbl(i, 1) = "種別"
  tbl(i, 2) = "コード"
  tbl(i, 3) = "数量"
  For Each key In u
    w = Filter(v, key)
    total = 0
    ii = 0
    For j = 0 To UBound(w)
      If dic(w(j)) > 0 Then
        i = i + 1: ii = ii + 1
        tbl(i, 2) = RTrim$(w(j))
        tbl(i, 3) = dic(w(j))
        total = total + dic(w(j))
        dic(w(j)) = 0
      End If
    Next
    If ii Then
      i = i + 1
      tbl(i, 1) = key
      tbl(i, 2) = "合計"
      tbl(i, 3) = total
    End If
  Next
  With Worksheets.Add(After:=WS1)
    With .Range("A1").Resize(n + 1, 3)
      .Value = tbl
      .Columns(3).NumberFormat = "#,##0"
      For Each c In .Columns(1).SpecialCells( _
              xlConstants, xlTextValues Or xlNumbers)
        c.Resize(, 3).Interior.ColorIndex = 34
      Next
    End With
    .Columns("A:C").AutoFit
  End With
End Sub


マルチポスト先のデータにも対応できるようにしてあります。

A列が邪魔でしたら、削除するコードを付け加えてください。

 A     B       C
種別    コード      数量
     636233030     21
     1636233030 90    4
63623   合計        25
     4561410021     10
     4561410021  400,000
     04561410021G0   15
     04561410021G0   53
45614   合計     400,078
     4166110010   38,000
     04166110010D6  4,000
4166110010 合計     42,000
     1175955026    100
     1175955026     12
11759   合計       112
     04517610060G0   11
4517610060 合計       11
0 hits

【58651】同じ文字列の検索 板さん 08/11/2(日) 23:32 質問
【58652】Re:同じ文字列の検索 kanabun 08/11/2(日) 23:42 発言
【58653】Re:同じ文字列の検索 板さん 08/11/3(月) 7:25 質問
【58657】Re:同じ文字列の検索 kanabun 08/11/3(月) 11:36 発言
【58658】Re:同じ文字列の検索 kanabun 08/11/3(月) 15:45 発言
【58660】Re:同じ文字列の検索 板さん 08/11/3(月) 18:14 お礼
【58661】Re:同じ文字列の検索 kanabun 08/11/3(月) 18:20 発言
【58662】Re:同じ文字列の検索 kanabun 08/11/3(月) 18:35 発言
【58663】Re:同じ文字列の検索 kanabun 08/11/3(月) 22:33 発言
【58664】Re:同じ文字列の検索 板さん 08/11/4(火) 0:14 お礼

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