Excel VBA質問箱 IV

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

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


33207 / 76734 ←次へ | 前へ→

【48751】Re:オートフィルターについて
発言  かみちゃん E-MAIL  - 07/5/4(金) 18:38 -

引用なし
パスワード
   こんにちは。かみちゃん です。

> シート1(List1)に累計値がないとフィルターでは無理でしょうか?
>シート1のデータは3店舗×3項目で1日9行が1年分あります
>係りは30係あります

方法はいろいろあると思いますが、私なら、SQLを使って累計値を計算します。
ただ、初心者や、AccessやSQLをご存知でない場合は、少々難しいかもしれません。
こんなこともできるのね、という程度で参考にしていただければと思います。

こちらでは、サンプルデータで動作確認できています。
(ただし、3係分でテストしました。)

Sub Sample1()
 Dim cn As Object
 Dim link_opt As String
 Dim idx As Long
 Dim rs As Object
 Dim mysql As String
 Dim WS1 As Worksheet
 Dim WS2 As Worksheet
 Dim rng1 As Range
 
 Set WS1 = Sheets("Sheet1")
 Set WS2 = Sheets("Sheet2")
 Set rng1 = WS1.Range("A1").CurrentRegion
 
 'Excelデータベースに接続
 link_opt = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
      "Data Source=" & ThisWorkbook.FullName & ";" & _
      "Extended Properties=Excel 8.0;"
 On Error Resume Next
 Set cn = CreateObject("ADODB.Connection")
 cn.Open link_opt
 On Error GoTo 0

 '接続OKの場合
 If Not cn Is Nothing And Err.Number = 0 Then
   mysql = "SELECT 日付 AS 抽出, 店舗, 項目, [1係], [2係], [3係] " & _
       "FROM [" & WS1.Name & "$" & rng1.Address(0, 0) & "] " & _
       "WHERE 日付=""20070402"" AND 店舗=""本店"" "
   mysql = mysql & " " & "UNION ALL "
   mysql = mysql & "SELECT ""累計"" AS 抽出, 店舗, 項目, Sum([1係]) AS 1係, Sum([2係]) AS 2係, Sum([3係]) AS 3係 " & _
       "FROM [" & WS1.Name & "$" & rng1.Address(0, 0) & "] " & _
       "WHERE 日付<=""20070402"" " & _
       "GROUP BY ""累計"", 店舗, 項目 " & _
       "HAVING 店舗=""本店"" "
  
  'データベースを開く
  On Error Resume Next
  Set rs = cn.Execute(mysql)
  On Error GoTo 0
   
  'データ取得
  If Not rs Is Nothing And Err.Number = 0 Then
   With WS2
    .Cells.ClearContents
    For idx = 0 To rs.fields.Count - 1
     .Cells(1, idx + 1).Value = rs.fields(idx).Name
    Next
    .Range("A2").CopyFromRecordset rs
    .Range("A1").CurrentRegion.Sort Key1:=Range("A2"), Order1:=xlAscending, _
     Key2:=Range("C2"), Order2:=xlDescending, Header:=xlGuess
   End With
  Else
   MsgBox "レコードセットを開けません"
  End If
  
  'データベースを閉じる
  On Error Resume Next
  rs.Close
  Set rs = Nothing
  On Error GoTo 0
  
  '接続を切断する
  On Error Resume Next
  cn.Close
  Set cn = Nothing
  On Error GoTo 0

 Else
  MsgBox "データベースに接続できません"
 End If
End Sub

1 hits

【48743】オートフィルターについて hiro 07/5/4(金) 15:12 質問
【48745】Re:オートフィルターについて かみちゃん 07/5/4(金) 17:10 発言
【48751】Re:オートフィルターについて かみちゃん 07/5/4(金) 18:38 発言
【48754】Re:オートフィルターについて hiro 07/5/4(金) 20:09 発言
【48755】Re:オートフィルターについて かみちゃん 07/5/4(金) 20:39 発言
【48760】Re:オートフィルターについて Hirofumi 07/5/5(土) 3:53 回答
【48761】Re:オートフィルターについて Hirofumi 07/5/5(土) 11:31 回答
【48762】Re:オートフィルターについて hiro 07/5/5(土) 22:16 発言
【48763】Re:オートフィルターについて Hirofumi 07/5/5(土) 23:37 回答
【48764】Re:オートフィルターについて Hirofumi 07/5/6(日) 1:23 回答
【48767】Re:オートフィルターについて Hirofumi 07/5/6(日) 18:37 回答
【48768】Re:オートフィルターについて hiro 07/5/6(日) 21:24 お礼

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