| |
Sub main()
Dim u
u = Array(集計(1), 集計(2), 集計(3), 集計(4), 集計(5), 集計(6), 集計(7), 集計(8), 集計(9))
Sheets("sheet2").Cells(1, 1).Resize(UBound(集計(1)) + 1, UBound(u) + 1).Value _
= Application.Transpose(u)
End Sub
Private Function 集計(clmn As Long) As Variant
Dim rngA As Range
Dim Dic As Object
Dim r As Range
Sheets("sheet1").Select
Set rngA = ActiveSheet.Range("b2", Range("b65536").End(xlUp))
Set Dic = CreateObject("Scripting.Dictionary")
For Each r In rngA.Cells
If clmn = 1 Then
Dic.Item(r.Text) = r.Text 'A列について
Else
Dic.Item(r.Text) = Dic.Item(r.Text) + r.Offset(, clmn - 1).Value
End If
Next
集計 = Dic.items()
'
Set r = Nothing
Set Dic = Nothing
Set rngA = Nothing
End Function
皆さん本当にどうもありがとうございます。
いろいろな作り方があるのだと改めて驚きました。Σ(･∀･`)
すごい！！！
ここで、またまた質問なんですが、kobasanさんが、ご提案下さった
ソースを以下の※〜※に入れ替えるとしたら、どのように変更すれば
よいのですか？
本当に初心者ですみません。。。(；・∀・)
Sub 集計_1()
Dim 日付 As Date
Dim レコード数 As Integer
Dim i, N As Integer
Dim Ws As Worksheet, Fi As Range, R As Range, C As Range, Ad As String
Sheets("sheet1").Select
Range("b2:j1000").Value = ""
Sheets("sheet2").Select
Range("b2:j1000").Value = ""
日付 = Sheets("印刷").Range("c4").Value
Sheets("データベース").Select
レコード数 = Range("a2").CurrentRegion.Rows.Count - 1
i = 0
For N = 3 To レコード数 + 2
Sheets("データベース").Select
If Month(Cells(N, 4).Value) = Month(日付) Then
If Year(Cells(N, 4).Value) = Year(日付) Then
If Cells(N, 2).Value = 1 Then
Sheets("データベース").Select
Cells(N, 5).Range("a1:l1").Select
Selection.Copy
Sheets("sheet1").Select
Cells(2 + i, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
i = i + 1
End If
End If
End If
Next N
Sheets("sheet1").Select
Range("B2:J1000").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
※ Set Ws = Worksheets("sheet2")
Application.ScreenUpdating = False
With Worksheets("sheet1")
.Range("b1", .Range("b65536").End(xlUp)).AdvancedFilter _
xlFilterCopy, , Ws.Range("b1"), True
Set R = Ws.Range("b2", Ws.Range("b65536").End(xlUp))
For Each C In R
Set Fi = .Columns(2).Find(C.Value, , xlValues, xlWhole)
If Not Fi Is Nothing Then
Ad = Fi.Address
Do
Set Fi = .Columns(2).FindNext(Fi)
Fi.Offset(, 1).Resize(, 8).Copy
C.Offset(, 1).PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
Loop Until Ad = Fi.Address
End If
Set Fi = Nothing
Next C
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
※ Set R = Nothing: Set Ws = Nothing
Sheets("sheet1").Select
Range("a1").Select
Sheets("データベース").Select
Range("a1").Select
Sheets("印刷").Select
Range("a1").Select
End Sub
|
|
ゆり
- 05/10/18(火) 9:55 -
