Excel VBA質問箱 IV

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

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


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

【34631】データ集計について G-3 06/2/8(水) 16:04 質問[未読]
【34632】Re:データ集計について ぴかる 06/2/8(水) 16:15 発言[未読]
【34692】Re:データ集計について G-3 06/2/9(木) 21:11 お礼[未読]
【34635】Re:データ集計について Statis 06/2/8(水) 17:09 回答[未読]
【34694】Re:データ集計について G-3 06/2/9(木) 21:32 質問[未読]
【34782】Re:データ集計について Statis 06/2/12(日) 13:14 発言[未読]
【34696】Re:データ集計について Kein 06/2/9(木) 22:38 回答[未読]
【34759】Re:データ集計について G-3 06/2/11(土) 17:05 お礼[未読]
【34774】Re:データ集計について G-3 06/2/12(日) 10:22 質問[未読]
【34780】Re:データ集計について とまと 06/2/12(日) 12:23 回答[未読]
【34781】Re:データ集計について Hirofumi 06/2/12(日) 13:03 回答[未読]
【34785】Re:データ集計について Kein 06/2/12(日) 17:30 回答[未読]
【34788】Re:データ集計について G-3 06/2/12(日) 21:22 質問[未読]
【34790】Re:データ集計について Statis 06/2/13(月) 8:11 発言[未読]
【34850】Re:データ集計について G-3 06/2/14(火) 19:21 質問[未読]
【34865】Re:データ集計について とまと 06/2/14(火) 22:55 質問[未読]
【34867】Re:データ集計について Statis 06/2/15(水) 8:50 発言[未読]
【34868】Re:データ集計について G-3 06/2/15(水) 10:50 お礼[未読]

【34631】データ集計について
質問  G-3 E-MAIL  - 06/2/8(水) 16:04 -

引用なし
パスワード
   教えてください
下記のようなシート1のデータからシート2に抽出するマクロの作り方

       sheet1            sheet2            
    データ            sheet1のAを基準にBのデータ個数抽出する            
    A    B                    
  1    い    a            a    b    c
  2    ろ    b          い    ?    ?    ?
  3    ろ    a          ろ    ?    ?    ?
  4    い    c          は    ?    ?    ?
  5    い    b                    
  6    は    b                    
  7    は    c                    

 オートフィルタでマクロを作りましたがデータが多いのでマクロが長くなり抽出に時間 がかかりすぎますので 効率的なVBAの書き方をご教授願います

【34632】Re:データ集計について
発言  ぴかる  - 06/2/8(水) 16:15 -

引用なし
パスワード
   G-3さん、こんにちは。

少しフォームが異なりますが、データ→ピボットテーブルにて集計可能と思います。
使うにあたって、慣れが必要ですけどネ。

【34635】Re:データ集計について
回答  Statis  - 06/2/8(水) 17:09 -

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

これで如何でしょうか?
(Sheet1の1行目は項目行とします。又、Sheet2はすべてのセルが空白である事)


Sub Test_Sum()
Dim Ws As Worksheet, C As Range, R As Range
Dim Fi As Range, Ad As String, Ma As Variant

Set Ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
Ws.Cells.Clear
With Worksheets("Sheet1")
   .Columns(1).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
   .Columns(2).AdvancedFilter xlFilterCopy, , Ws.Range("B1"), True
   With Ws.Range("B2", Ws.Range("B65536").End(xlUp))
     .Copy
     Ws.Range("B1").PasteSpecial xlPasteAll, , , True
     .Clear
     Set R = .Offset(, -1)
   End With
   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)
       Ma = Application.Match(Fi.Offset(, 1).Value, Ws.Rows(1), 0)
       If Not IsError(Ma) Then
         C.Offset(, Ma - 1).Value = C.Offset(, Ma - 1).Value + 1
       End If
      Loop Until Ad = Fi.Address
      Set Fi = Nothing
     End If
   Next C
End With
Application.ScreenUpdating = True
Set R = Nothing

End Sub

【34692】Re:データ集計について
お礼  G-3 E-MAIL  - 06/2/9(木) 21:11 -

引用なし
パスワード
   ▼ぴかる さん:
>G-3さん、こんにちは。
>
>少しフォームが異なりますが、データ→ピボットテーブルにて集計可能と思います。
>使うにあたって、慣れが必要ですけどネ。

ひかるさん 
ありがとうございました 
ピボットテーブルを少し勉強してみます

【34694】Re:データ集計について
質問  G-3 E-MAIL  - 06/2/9(木) 21:32 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>
>これで如何でしょうか?
>(Sheet1の1行目は項目行とします。又、Sheet2はすべてのセルが空白である事)
>
>
>Sub Test_Sum()
>Dim Ws As Worksheet, C As Range, R As Range
>Dim Fi As Range, Ad As String, Ma As Variant
>
>Set Ws = Worksheets("Sheet2")
>Application.ScreenUpdating = False
>Ws.Cells.Clear
>With Worksheets("Sheet1")
>   .Columns(1).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
>   .Columns(2).AdvancedFilter xlFilterCopy, , Ws.Range("B1"), True
>   With Ws.Range("B2", Ws.Range("B65536").End(xlUp))
>     .Copy
>     Ws.Range("B1").PasteSpecial xlPasteAll, , , True
>     .Clear
>     Set R = .Offset(, -1)
>   End With
>   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)
>       Ma = Application.Match(Fi.Offset(, 1).Value, Ws.Rows(1), 0)
>       If Not IsError(Ma) Then

>  ***   C.Offset(, Ma - 1).Value = C.Offset(, Ma - 1).Value + 1
>       End If
>      Loop Until Ad = Fi.Address
>      Set Fi = Nothing
>     End If
>   Next C
>End With
>Application.ScreenUpdating = True
>Set R = Nothing
>
>End Sub

statis さん こんばんは ありがとうございました
プログラムを走らせたところ 上記の***しるしの行で実行時エラーとなり
型が一致しないと メッセージが出ました 抽出結果はつぎのようになっていました
A  a  b  c
い    1  1



どうしたらよろしいでしょうか
プログラムの理解に苦しんでいます

【34696】Re:データ集計について
回答  Kein  - 06/2/9(木) 22:38 -

引用なし
パスワード
   これで、どうでしょーか ? こちらのテストではうまくいきましたが。

Sub Test_Count()
  Dim MyR As Range, C As Range
  Dim MyV As Variant, x As Variant, y As Variant
 
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
   If .Range("A1").CurrentRegion.ListHeaderRows = 0 Then
     .Rows(1).Insert xlShiftDown
     .Range("A1:B1").Value = Array("Data1", "Data2")
   End If
   .Range("A1", .Range("A65536").End(xlUp)).AdvancedFilter _
    xlFilterCopy, , Sheets("Sheet2").Range("A1"), True
   .Range("B1", .Range("B65536").End(xlUp)).AdvancedFilter _
    xlFilterCopy, , Sheets("Sheet2").Range("B1"), True
   If .Range("A1").Value = "Data1" Then
     .Rows(1).Delete xlShiftUp
     Set MyR = .Range("A1", .Range("A65536").End(xlUp))
   Else
     Set MyR = .Range("A2", .Range("A65536").End(xlUp))
   End If
  End With
  With Sheets("Sheet2")
   .Range("A1").ClearContents
   With .Range("B2", .Range("B65536").End(xlUp))
     MyV = WorksheetFunction.Transpose(.Value)
     .ClearContents
   End With
   .Range("B1").Resize(, UBound(MyV)).Value = MyV
   For Each C In MyR
     x = Application.Match(C.Value, .Range("A:A"), 0)
     y = Application.Match(C.Offset(, 1).Value, .Rows(1), 0)
     .Cells(x, y).Value = .Cells(x, y).Value + 1
   Next
   .Activate
  End With
  Application.ScreenUpdating = True: Set MyR = Nothing
End Sub

【34759】Re:データ集計について
お礼  G-3 E-MAIL  - 06/2/11(土) 17:05 -

引用なし
パスワード
   keinさん ありがとうございました
うまく集計できました
実際のデータに当てはめてみます
縦と横の項目の配列は決まっていて転記先の表に入力されていますので
データのみを集計転記することになりますので少し変更を要しますが
勉強しながら直してみます
出来なかったらまた教えてください よろしくおねがいします
                        G-3

【34774】Re:データ集計について
質問  G-3 E-MAIL  - 06/2/12(日) 10:22 -

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

マクロの修正できませんでした
私の質問の仕方が悪かったのですね
根本的修正が必要と感じました
つまり、抽出した表のX,Y軸の項目は決まってまして、元データは
その項目がランダムに入力されます 項目の無いものは入力されません
お手数をかけますが教えてください

【34780】Re:データ集計について
回答  とまと  - 06/2/12(日) 12:23 -

引用なし
パスワード
   ▼G-3 さん:

こんにちは

関数の貼り付けで考えてみました。

Sub tes()

Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim rngA As Range
Dim rngB As Range

Set sh1 = Sheets("sheet1")
Set sh2 = Sheets("sheet2")


'C列に作業列を追加
Set rngA = sh1.Range("a1", sh1.[a65536].End(xlUp)).Offset(, 2)
With rngA
.Formula = "= a1 & b1"
.Value = .Value
End With


'関数の貼り付け
Set rngB = sh2.Range("A1").CurrentRegion
With Intersect(rngB, rngB.Offset(1, 1))
.Formula = "=COUNTIF(Sheet1!" & rngA.Address & ",$A2&B$1) "
.Value = .Value
End With


'C列の後かたずけ
rngA.ClearContents

Set sh1 = Nothing
Set sh2 = Nothing
Set rngA = Nothing
Set rngB = Nothing


End Sub

【34781】Re:データ集計について
回答  Hirofumi  - 06/2/12(日) 13:03 -

引用なし
パスワード
   >つまり、抽出した表のX,Y軸の項目は決まってまして、元データは
>その項目がランダムに入力されます 項目の無いものは入力されません

「項目の無いものは入力されません」と言うのが、「項目の無い物は、カウントしません」
の意味なら、以下の様でも善いかも?(余り速く無いけど?)

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngRows As Long
  Dim lngRow As Long
  Dim lngColumn As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntRows As Variant
  Dim vntColumns As Variant
  Dim strProm As String
  
  'Sheet1のListの左上隅セル位置を基準として設定
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
    'データが無い場合
    If lngRows <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Resize(lngRows, 2).Value
  End With
  
  'Sheet2Listの左上隅セル位置を基準として設定(見出しの「a」の左、「い」の上のセル位置)
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  With rngResult
    '行見出しの行数を取得
    lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'データが有る場合
    If lngRow > 0 Then
      vntRows = .Offset(1).Resize(lngRow + 1).Value
    End If
    '列見出しの列数を取得
    lngColumn = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
    'データが有る場合
    If lngColumn > 0 Then
      vntColumns = .Offset(, 1).Resize(, lngColumn + 1).Value
    End If
    '結果出力用配列を確保
    ReDim vntResult(1 To lngRow, 1 To lngColumn)
  End With
  
  'カウントを集計
  For i = 1 To lngRows
    'A列の値をListの行見出しから探索する
    lngRow = GetRowPos(vntData(i, 1), vntRows)
    '値が合った場合
    If lngRow > 0 Then
      'B列の値をListの列見出しから探索する
      lngColumn = GetColumnPos(vntData(i, 2), vntColumns)
      '値が合った場合
      If lngColumn > 0 Then
        '結果配列にカウントする
        vntResult(lngRow, lngColumn) _
            = vntResult(lngRow, lngColumn) + 1
      End If
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '結果を出力
  rngResult.Offset(1, 1).Resize(UBound(vntResult, 1), _
        UBound(vntResult, 2)).Value = vntResult
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetRowPos(vntKey As Variant, vntScope As Variant) As Long

  Dim i As Long
  Dim lngListEnd As Long
  
  '行見出しが無い場合
  If VarType(vntScope) = vbVariant Then
    Exit Function
  End If
  
  '行見出しの行数を取得
  lngListEnd = UBound(vntScope, 1) - 1
  
  For i = 1 To lngListEnd
    'もし、行見出しと探索Keyが合致したら戻り値として行位置を返す
    If StrComp(vntKey, vntScope(i, 1), vbTextCompare) = 0 Then
      GetRowPos = i
      Exit Function
    End If
  Next i
  
End Function

Private Function GetColumnPos(vntKey As Variant, vntScope As Variant) As Long

  Dim i As Long
  Dim lngListEnd As Long
  
  If VarType(vntScope) = vbVariant Then
    Exit Function
  End If
  
  lngListEnd = UBound(vntScope, 2) - 1
  
  For i = 1 To lngListEnd
    If StrComp(vntKey, vntScope(1, i), vbTextCompare) = 0 Then
      GetColumnPos = i
      Exit Function
    End If
  Next i
  
End Function

【34782】Re:データ集計について
発言  Statis  - 06/2/12(日) 13:14 -

引用なし
パスワード
   こんにちは
Sheet1の1行目は項目行になっていますか?

【34785】Re:データ集計について
回答  Kein  - 06/2/12(日) 17:30 -

引用なし
パスワード
   それなら↓このように、コードを大幅に省略することとMatch関数の戻り値の判定を
追加することで、うまくいくと思いますが。

Sub Test_Count2()
  Dim MyR As Range, C As Range
  Dim x As Variant, y As Variant
 
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    Set MyR = .Range("A1", .Range("A65536").End(xlUp))
  End With
  With Sheets("Sheet2")
   For Each C In MyR
     x = Application.Match(C.Value, .Range("A:A"), 0)
     y = Application.Match(C.Offset(, 1).Value, .Rows(1), 0)
    If Not IsError(x) And Not IsError(y) Then
      .Cells(x, y).Value = .Cells(x, y).Value + 1
    End If
   Next
   .Activate
  End With
  Application.ScreenUpdating = True: Set MyR = Nothing
End Sub

Sheet1 の1行目が項目なら、

Set MyR = .Range("A2", .Range("A65536").End(xlUp))

と、変更して下さい。

【34788】Re:データ集計について
質問  G-3 E-MAIL  - 06/2/12(日) 21:22 -

引用なし
パスワード
   Keinさん ありがとうございました 
x、yの項目を増やしてデータを入れデバックしたところ x、y同一座標のセルにカウントされません どこを直せばいいんでしょうか

▼Kein さん:
>それなら↓このように、コードを大幅に省略することとMatch関数の戻り値の判定を
>追加することで、うまくいくと思いますが。
>
>Sub Test_Count2()
>  Dim MyR As Range, C As Range
>  Dim x As Variant, y As Variant
> 
>  Application.ScreenUpdating = False
>  With Sheets("Sheet1")
>    Set MyR = .Range("A1", .Range("A65536").End(xlUp))
>  End With
>  With Sheets("Sheet2")
>   For Each C In MyR
>     x = Application.Match(C.Value, .Range("A:A"), 0)
>     y = Application.Match(C.Offset(, 1).Value, .Rows(1), 0)
>    If Not IsError(x) And Not IsError(y) Then
>      .Cells(x, y).Value = .Cells(x, y).Value + 1
>    End If
>   Next
>   .Activate
>  End With
>  Application.ScreenUpdating = True: Set MyR = Nothing
>End Sub
>
>Sheet1 の1行目が項目なら、
>
>Set MyR = .Range("A2", .Range("A65536").End(xlUp))
>
>と、変更して下さい。

【34790】Re:データ集計について
発言  Statis  - 06/2/13(月) 8:11 -

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

>つまり、抽出した表のX,Y軸の項目は決まってまして
上記のシートシートアウトを教えてください。(項目行も含めて)

【34850】Re:データ集計について
質問  G-3 E-MAIL  - 06/2/14(火) 19:21 -

引用なし
パスワード
   Statisさん こんばんは

シートシートアウトは下記のとおりです

データシート データ項目はAとBです AとBのデータはアウトシートのX・Y軸の項目内 容がランダムに入力されます
 A   B
 あ  a 
 か  c
 し  k
 と  a
 い  k
 ・
 ・
 ・

 アウトシートのX・Y軸の項目配列は決まっています
 アウトシートのX軸の項目に対しY軸項目と同じデータ個数をカウントして抽出したいの です。アウトシートには他のデータもありますのでセルを指定する必要もあります
 
項目 k c a ・・・
 い ? ? ?
 と ? ? ?
 あ ? ? ?
 か ? ? ?
 ・
 ・
 ・
   よろしくお願いします


▼Statis さん:
>こんにちは
>
>>つまり、抽出した表のX,Y軸の項目は決まってまして
>上記のシートシートアウトを教えてください。(項目行も含めて)

【34865】Re:データ集計について
質問  とまと  - 06/2/14(火) 22:55 -

引用なし
パスワード
   ▼G-3 さん:


レイアウトを提示する場合行数も大事なので
行数も提示したレイアウトにしてください。
まだ、不明ですので何個か確認します。

1) データシート(sheet1)は見出しなしですか?


> A   B
> あ  a 
> か  c
> し  k
> と  a
> い  k
> ・
> ・
 
  ↓ こうですか?(予想)


  A   B
1  あ  a 
2  か  c
3  し  k
4  と  a
5  い  k
6  ・


>アウトシートには他のデータもありますのでセルを指定する必要もあります
2)他のデータって何ですか?(タイトとか日付ですか)
 他のデータも提示してください。


>項目 k c a ・・・
> い ? ? ?
> と ? ? ?
> あ ? ? ?
> か ? ? ?
> ・
> ・

  ↓ こうですか?(予想)

  A  B  C  D
1 項目  k  c  a
2 い  ?  ?  ?
3 と  ?  ?  ?
4 あ  ?  ?  ?
5 か
6

【34867】Re:データ集計について
発言  Statis  - 06/2/15(水) 8:50 -

引用なし
パスワード
   こんいちは
う〜ん、そのデータシートで入力するセルのアドレスを
どうやってしるのでしょうか?
X,Y軸は固定ですか?

もし固定でないなら、私が提示したレイアウトには出来ないのでしょうか?

【34868】Re:データ集計について
お礼  G-3 E-MAIL  - 06/2/15(水) 10:50 -

引用なし
パスワード
   Keinさん 
ご迷惑をおかけしました
マクロはうまく動きました
私のデータの入力ミスでした 入力文字の型が間違っていました
助かりました。ありがとうございました。


▼Kein さん:
>それなら↓このように、コードを大幅に省略することとMatch関数の戻り値の判定を
>追加することで、うまくいくと思いますが。
>
>Sub Test_Count2()
>  Dim MyR As Range, C As Range
>  Dim x As Variant, y As Variant
> 
>  Application.ScreenUpdating = False
>  With Sheets("Sheet1")
>    Set MyR = .Range("A1", .Range("A65536").End(xlUp))
>  End With
>  With Sheets("Sheet2")
>   For Each C In MyR
>     x = Application.Match(C.Value, .Range("A:A"), 0)
>     y = Application.Match(C.Offset(, 1).Value, .Rows(1), 0)
>    If Not IsError(x) And Not IsError(y) Then
>      .Cells(x, y).Value = .Cells(x, y).Value + 1
>    End If
>   Next
>   .Activate
>  End With
>  Application.ScreenUpdating = True: Set MyR = Nothing
>End Sub
>
>Sheet1 の1行目が項目なら、
>
>Set MyR = .Range("A2", .Range("A65536").End(xlUp))
>
>と、変更して下さい。

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