Excel VBA質問箱 IV

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

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


8967 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

【29829】データの小計をだしたい
質問  ゆり  - 05/10/14(金) 14:46 -

引用なし
パスワード
      A    B    C    D    E
1 氏名   件数1  件数2 金額  金額2
2 佐藤    3     4   300   200
3 佐藤    2     3   200   150   
4 小林    2     2   300   200
5 田中    1     2   100   350   
6 田中    4     3   600   400
7 田中    2     3   300   200

9 

シート名:処理

上記のような表(データベースから条件にあった
データのみ抽出しているので件数固定ではない)
があり、氏名ごとに、件数1,2・金額1,2で
それぞれ小計を出したいと思っています。
結果に関しては、別のシート:結果表示 にフォーマット
を作ってあるので結果を当てはめられればと思います。

EXCELの自動マクロ作成機能を使って集計をしてみたり
A列の下のセルと見比べて同じデータならそれぞれのデータを
足していく処理を作ってみたりしたのですがうまくいかず
いきづまっています・・・

どなたか教えていただけませんでしょうか。
お願いいたします。(*_ _)人

【29833】Re:データの小計をだしたい
発言  Statis  - 05/10/14(金) 15:10 -

引用なし
パスワード
   ▼ゆり さん:
こんにちは

>結果に関しては、別のシート:結果表示 にフォーマット
>を作ってあるので結果を当てはめられればと思います。
どのようなフォーマットになっているのですか?

処理シートが結果シートにどのように集計されれば良いのか
記載してください。

【29835】Re:データの小計をだしたい
お礼  ゆり  - 05/10/14(金) 15:25 -

引用なし
パスワード
   早速の回答ありがとうございます!!

>どのようなフォーマットになっているのですか?

>処理シートが結果シートにどのように集計されれば良いのか
>記載してください。

   A    B    C    D    E
1 氏名   件数1  件数2 金額  金額2
2 佐藤    3     4   300   200
3 佐藤    2     3   200   150   
4 小林    2     2   300   200
5 田中    1     2   100   350   
6 田中    4     3   600   400
7 田中    2     3   300   200

説明不足ですみません!
結果シートは、日付が入力されているセルがあったり罫線で飾りが
ついたりしているだけで、集計した値を表示させる項目数は同じです。

上の表の例だと、別シート:結果シート の E14のセルから

   E   F  G  H   I
14 佐藤   5  7  500  350
15 小林   2  2  300  200
16 田中   7  8  1000 950 

と表示させたいと思います。
また、合計については、表の一番下にSUM関数を
入れてあるので、小計だけを別シートに取り出したい
と考えています。

【29843】Re:データの小計をだしたい
回答  Statis  - 05/10/14(金) 16:39 -

引用なし
パスワード
   こんにちは

データシート=Sheet1
集計シート=Sheet2
と設定しています(そちらの環境に合わせてください)

ではお試しを。

Sub test_1()
Dim Ws As Worksheet, Fi As Range, R As Range, C As Range, Ad As String
Set Ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
   .Columns(1).AdvancedFilter xlFilterInPlace, , , True
   .Range("A2", .Range("A65536").End(xlUp)) _
     .SpecialCells(xlCellTypeVisible).Copy Ws.Range("E14")
   .ShowAllData
   Set R = Ws.Range("E14", Ws.Range("E65536").End(xlUp))
   For Each C In R
     Set Fi = .Columns(1).Find(C.Value, , xlValues, xlWhole)
     If Not Fi Is Nothing Then
      Ad = Fi.Address
      Do
       Set Fi = .Columns(1).FindNext(Fi)
       Fi.Offset(, 1).Resize(, 4).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
End Sub

【29847】Re:データの小計をだしたい
お礼  ゆり  - 05/10/14(金) 16:58 -

引用なし
パスワード
   Statis さん (TдT) ありがとうございます。
早速試してみます!!!!

【29963】Re:データの小計をだしたい
質問  ゆり  - 05/10/17(月) 16:26 -

引用なし
パスワード
   お世話になっています。
Statis さんに教えていただいたソースでばっちりだったのですが、
sheet1の元表のデータが一件だけだと以下のエラーが出てしまいました。
(デバック:上部※がついている2行)

実行時エラー'1004':
コピー領域と貼り付け領域の形が違うため、情報を貼り付けることができません。情報を貼り付けるには、次のいずれかの操作を行ってください。
1つのセルをクリックし、貼り付けてみてください。
貼り付け元の形を確かめ、適切な範囲を選択したあと、貼り付けてみてください。

Sub test_1()
Dim Ws As Worksheet, Fi As Range, R As Range, C As Range, Ad As String
Set Ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
   .Columns(1).AdvancedFilter xlFilterInPlace, , , True
※   .Range("A2", .Range("A65536").End(xlUp)) _
※     .SpecialCells(xlCellTypeVisible).Copy Ws.Range("E14")
   .ShowAllData
   Set R = Ws.Range("E14", Ws.Range("E65536").End(xlUp))
   For Each C In R
     Set Fi = .Columns(1).Find(C.Value, , xlValues, xlWhole)
     If Not Fi Is Nothing Then
      Ad = Fi.Address
      Do
       Set Fi = .Columns(1).FindNext(Fi)
       Fi.Offset(, 1).Resize(, 4).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
End Sub


「On Error GoTo」でsheet1一行分の各セルの値をsheet2の対応セルに代入
していこうとしたのですが、なぜかコンパイルエラーが出てしまいました。

一行の場合はエラーを出さずにその一行を表示させる処理にしたいのですが何かいい方法はありますでしょうか?
教えてください!!

【29966】Re:データの小計をだしたい
発言  とまと  - 05/10/17(月) 16:44 -

引用なし
パスワード
   ゆり さん こんにちは。

下記のようにすれば大丈夫かもしれません。
ただ "Sheet2"のE13を書き換えてしまうので
後で書き直す処理をかかなくてはいけないかも。


Sub test_2()
Dim Ws As Worksheet, Fi As Range, R As Range, C As Range, Ad As String
Set Ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
   .Range("A1", .Range("A65536").End(xlUp)).AdvancedFilter _
   xlFilterCopy, , Ws.Range("E13"), True
                               
   Set R = Ws.Range("E14", Ws.Range("E65536").End(xlUp))
   For Each C In R
     Set Fi = .Columns(1).Find(C.Value, , xlValues, xlWhole)
     If Not Fi Is Nothing Then
      Ad = Fi.Address
      Do
       Set Fi = .Columns(1).FindNext(Fi)
       Fi.Offset(, 1).Resize(, 4).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
End Sub

【29977】Re:データの小計をだしたい
質問  ゆり  - 05/10/17(月) 17:14 -

引用なし
パスワード
   とまとさんありがとうございました。
"Sheet2"のE13が書き換わるのは問題ないのでこのソースで解決しました。
どうもありがとうございました!!

しかし、また問題が出てきてしまいました。(*_ _)人
0件の場合に以下のエラーが出てきました。
頼りっぱなしで大変申し訳ないのですが何かいい処理は
あるでしょうか?お教え願います。(_ _(--;(_ _(--; ペコペコ


実行時エラー'1004'
このコマンドにはデータソースが2行以上必要です。選択したセル範囲に1行しか含まれていない場合はこのコマンドを実行できません。次のいずれかの操作を行ってください。
・フィルタオプションを使用している場合、2行以上のデータで構成されるセル範囲を選択し、[フィルタオプションの設定]コマンドを再度クリックします。
・ピボットテーブルを使用している場合は、セル参照を入力するか、または2行以上の・・・


Sub test_2()
Dim Ws As Worksheet, Fi As Range, R As Range, C As Range, Ad As String
Set Ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
※   .Range("A1", .Range("A65536").End(xlUp)).AdvancedFilter _
※   xlFilterCopy, , Ws.Range("E13"), True
                               
   Set R = Ws.Range("E14", Ws.Range("E65536").End(xlUp))
   For Each C In R
     Set Fi = .Columns(1).Find(C.Value, , xlValues, xlWhole)
     If Not Fi Is Nothing Then
      Ad = Fi.Address
      Do
       Set Fi = .Columns(1).FindNext(Fi)
       Fi.Offset(, 1).Resize(, 4).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
End Sub

【29979】Re:データの小計をだしたい
発言  とまと  - 05/10/17(月) 17:40 -

引用なし
パスワード
   せんとうを下記に差し替えてみてください。


Sub test_3()
Dim Ws As Worksheet, Fi As Range, R As Range, C As Range, Ad As String
Set Ws = Worksheets("Sheet2")

If Ws.Range("A65536").End(xlUp).Row = 1 Then
  MsgBox "データがありません。"
  Exit Sub
End If

【29983】Re:データの小計をだしたい
発言  kobasan  - 05/10/17(月) 18:13 -

引用なし
パスワード
   みなさん 今晩は。

前に作っていたのですが、タイミング遅すぎたのでそのままにしていました。
また、質問があったので、のせてみます。

別のやり方ですけど、試してみてください。

Sub main()
Dim u
  u = Array(集計(1), 集計(2), 集計(3), 集計(4), 集計(5))
  
  Sheets("結果シート").Cells(14, 5).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
 
  Set rngA = ActiveSheet.Range("A1", Range("A65536").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

【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

【30042】Re:データの小計をだしたい
回答  kobasan  - 05/10/18(火) 19:01 -

引用なし
パスワード
   ▼ゆり さん 今晩は

前半コードをよく理解してないので、多分ですが、
以下のコードを同じモジュールに入れると、できると思います。
変更箇所は

  '※ 
   main
  '※ 
のところだけですむと思います。
うまくいかなかったら、質問してください


>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
>

>
>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
>
>
  '※ 
   main
  '※ 
>
>
> Sheets("sheet1").Select
> Range("a1").Select
> Sheets("データベース").Select
> Range("a1").Select
> Sheets("印刷").Select
> Range("a1").Select
> 
>  
>End Sub

【30076】Re:データの小計をだしたい
発言  kobasan  - 05/10/19(水) 7:22 -

引用なし
パスワード
   ▼ゆり さん おはようございます。

>ここで、またまた質問なんですが、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

【30082】Re:データの小計をだしたい
お礼  ゆり  - 05/10/19(水) 10:41 -

引用なし
パスワード
   ▼kobasan さん:ほんとうにありがとうございました。

やはり、配列を使用すると処理が早いのでkobasanさんの提案して
くださったソースを使ってみようと思います。

初心者なのでまだ理解できていないため自分の環境に合わせると
うまく処理できていませんが、これからソースとにらめっこして
完成させたいと思います。

今回は本当にどうもありがとうございました。
今後ともよろしくお願いいたします。(*_ _)人

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