|
▼ゆり さん おはようございます。
>ここで、またまた質問なんですが、kobasanさんが、ご提案下さった
>ソースを以下の※〜※に入れ替えるとしたら、どのように変更すれば
>よいのですか?
この形をにしたかったのかな。
これでもうまく動くと思います。
>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
>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
>
>
'※
Dim u '<===先頭のDimのところに集めてもいいです。
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)
'※
>
>
> Sheets("sheet1").Select
> Range("a1").Select
> Sheets("データベース").Select
> Range("a1").Select
> Sheets("印刷").Select
> Range("a1").Select
>
>
>End Sub
|
|