Excel VBA質問箱 IV

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

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


51590 / 76732 ←次へ | 前へ→

【30005】Re:データの小計をだしたい
質問  ゆり  - 05/10/18(火) 9:55 -

引用なし
パスワード
   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
0 hits

【29829】データの小計をだしたい ゆり 05/10/14(金) 14:46 質問
【29833】Re:データの小計をだしたい Statis 05/10/14(金) 15:10 発言
【29835】Re:データの小計をだしたい ゆり 05/10/14(金) 15:25 お礼
【29843】Re:データの小計をだしたい Statis 05/10/14(金) 16:39 回答
【29847】Re:データの小計をだしたい ゆり 05/10/14(金) 16:58 お礼
【29963】Re:データの小計をだしたい ゆり 05/10/17(月) 16:26 質問
【29966】Re:データの小計をだしたい とまと 05/10/17(月) 16:44 発言
【29977】Re:データの小計をだしたい ゆり 05/10/17(月) 17:14 質問
【29979】Re:データの小計をだしたい とまと 05/10/17(月) 17:40 発言
【29983】Re:データの小計をだしたい kobasan 05/10/17(月) 18:13 発言
【30005】Re:データの小計をだしたい ゆり 05/10/18(火) 9:55 質問
【30042】Re:データの小計をだしたい kobasan 05/10/18(火) 19:01 回答
【30076】Re:データの小計をだしたい kobasan 05/10/19(水) 7:22 発言
【30082】Re:データの小計をだしたい ゆり 05/10/19(水) 10:41 お礼

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