Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

23441 / 76738

←次へ　｜　前へ→


	【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

3 hits

▼

【58651】同じ文字列の検索 板さん 08/11/2(日) 23:32