Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2007)
フィルタがおかしくなるのは
投稿日時: 19/02/25 10:51:12
投稿者: FILETUBE

こんにちは。
1つ教えて下さい。
 
元シートを集計し、計算結果シートにコピーし
最終実績集計シートに表示しています。
 
その実績集計シートにフィルタがかかったまま保存してあります。
ブックを開いて別シートに移動し、再度この実績集計シートに
戻すとフィルタがかかって4行のはずが1行表示されず、
また2行別の行が表示され5行の表示になってしまいます。
 
再度別シートに移動し、再度この実績集計シートに戻すと
正しく4行で表示されます。その後は何度移動してもOKです。
 
最初の1回目だけが正しく表示されません。
その状態でフィルタのマークをクリックしフィルタを実行すると
正しく表示されます。
 
 
例えば
項目1 数量
A 10
A 20
A 30
A 40

 
項目1 数量
B 5
A 20
A 30
A 40
C 6
と表示されてしまいます(本来は項目は5つです)
 
少し長いのですが、コードになります。
 
 
Private Sub Worksheet_Activate()
 
    Dim wks As Worksheet
    Set wks = ThisWorkbook.Worksheets("実績集計")
     
    Dim wks2 As Worksheet
    Set wks2 = ThisWorkbook.Worksheets("計算結果")
    '@Dictionaryへ退避
    Dim dic As Object
    Dim vLst As Long
    Dim y As Long
    Dim skey As String
   
    vLst = wks.Range("A1").SpecialCells(xlLastCell).Row
    Set dic = CreateObject("Scripting.Dictionary")
    '
    For y = 2 To vLst
        If wks.Cells(y, 1).Value <> "" Then
            skey = wks.Cells(y, 1).Value & wks.Cells(y, 2).Value & _
                   wks.Cells(y, 3).Value & wks.Cells(y, 4).Value & _
                   wks.Cells(y, 5).Value
            dic.Add skey, wks.Cells(y, 7).Resize(, 11).Value 'Itemには配列(.Value)を格納
 
        End If
    Next
     
    'A集計セット
    Const adOpenKeyset = 1
    Const adLockReadOnly = 1
  
    Dim cn As Object
    Dim rs As Object
    Dim strSQL As String
      
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    cn.Provider = "Microsoft.ACE.OLEDB.12.0"
    cn.Properties("Extended Properties") = "Excel 12.0;HDR=YES;IMEX=1"
    cn.Open "C:\test\伝票.xls"
    '*****************************************************************************
    strSQL = strSQL & " SELECT 項目1,項目2,項目3,項目4,項目5,SUM(数量) AS 数量
    strSQL = strSQL & " FROM 元シート "
    strSQL = strSQL & " GROUP BY 項目1,項目2,項目3,項目4,項目5"
    strSQL = strSQL & " ORDER BY 項目1,項目2,項目3,項目4,項目5"
    '*****************************************************************************
    rs.Open strSQL, cn, adOpenKeyset, adLockReadOnly
    Application.ScreenUpdating = False
    '集計シートをクリア
    wks.Range("A3:P" & Rows.Count).ClearContents
    '計算結果シートをクリア
    wks2.Range("A1:F" & Rows.Count).ClearContents
    '計算結果シートにデータを出力する
    wks2.Range("A1").CopyFromRecordset rs
    '計算結果シート⇒集計シートにコピー
    wks2.Range("A1:F" & rs.RecordCount).Copy Destination:=Sheets("実績集計").Range("A3")
 
    '再度最終行取得
    vLst = ThisWorkbook.Worksheets("実績集計").Range("A1").SpecialCells(xlLastCell).Row
    Application.ScreenUpdating = True
    '後処理
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
     
    'B出荷数再セット
    For y = 2 To vLst
        skey = wks.Cells(y, 1).Value & wks.Cells(y, 2).Value & _
               wks.Cells(y, 3).Value & wks.Cells(y, 4).Value & _
               wks.Cells(y, 5).Value
        If dic.Exists(skey) Then 'Keyが存在したら
            wks.Cells(y, 7).Resize(1, 11).Value = dic.Item(skey) '該当データを戻す
        End If
    Next
End Sub
 
 
なぜ1回目だけがフィルタが勝手におかしくなってしまうのでしょうか?
分かる方おられましたら教えて頂けないでしょうか。
宜しくお願いします。

回答
投稿日時: 19/02/25 12:25:50
投稿者: Suzu

フィルター云々のコードは提示されたコードに見当たらないです。
再現するだけの情報を、このスレッドだけでは、提示頂けていません。
提示頂いた条件のデータで、コードを実行しようとしても、エラーになるだけです。。
 
シングルステップで実施する等、デバックをご自分で実施した上でのご質問でしょうか。
 
気になる点としては、
 
SpecialCells(xlLastCell).Row
 で最終行を取得しようとされていますが、その直前に、ClearContents をおこなっております。
 
消すまえの最終行が、消した後の最終行より大きい場合、
SpecialCells(xlLastCell).Row で 得られる最終行は、消す前の最終行です。
 
 
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_030_100.html
https://www.sejuku.net/blog/28929
 
何にしても、フィルター云々が、提示されたコードでは再現できない以上、なんとも言えません。

投稿日時: 19/02/25 14:25:55
投稿者: FILETUBE

回答ありがとうございます。
フィルタはコードではなく、手動で設定しています。
シングルステップで実施はしています。
ClearContentsは65536行までとなっています。
 
今のフィルタの条件でそのまま再実行するというコードは
ないでしょうか?
 
どうぞよろしくお願いします。

回答
投稿日時: 19/02/25 18:09:46
投稿者: Suzu

引用:
シングルステップで実施はしています。
ClearContentsは65536行までとなっています。

 
どこかで、フィルター対象のシート上のデータを消して、
どこかで、フィルター対象のシート上にデータを書き込んでいるのでは?
 
その段階で、変になっているのでは?
 
そのステップを確認しましたか?
 
 
もともと設定されていた、フィルター対象のRow数と、
新たに張り付けたデータの Row数は一致するのでしょうか?
 
VBAでデータ削除しているのに、勝手にフィルターが設置されるのですか?
 
 
 
また、リンクした井上さんのHPでは、
引用:
「.End(xlDown)」や「.End(xlUp)」は手動操作での「Ctrl+↓」「Ctrl+↑」と同じです。 上記の注意事項に記載したとおりで、どの方法でもオートフィルタの抽出中は、表示行の中で動作するので実際の最終行にならない場合があります。
最終行判定の操作の前にオートフィルタの抽出状態を解除してしまえば正しい最終行が得られます。

が紹介されていますが、関係ありませんか?
 
 
引用:
今のフィルタの条件でそのまま再実行するというコードはないでしょうか?

FILETUBEさんのコード解析力があれば、オートフィルターをマクロ記録で行ってみれば
オートフィルターの条件の取得方法もお分かりになると思うのですが。。
 
If wst.AutoFilterMode = True Then
  For i = 1 To wst.AutoFilter.Filters.Count
    If wst.AutoFilter.Filters(i).On Then
      Debug.Print wst.AutoFilter.Range(1, i) & vbTab & wst.AutoFilter.Filters(i).Criteria1
    End If
  Next i
End If

投稿日時: 19/02/25 21:25:10
投稿者: FILETUBE

回答ありがとうございます。
フィルタ対象のシートはフィルタがかかったまま
Clearcontentsでクリアしています。
そしてその後データをコピーしています。
 
元々はフィルタの保存、フィルタの解除、データセット、フィルタの復元の
処理手順で実行しようと思っていましたが断念しました。
 
最初だけフィルタがおかしくなり、2回目以降は正しく表示されます。
現在のフィルタ状態を退避し、そのまま実行するコードを記述すると
どうなるのかと思います。

回答
投稿日時: 19/02/26 10:56:42
投稿者: Suzu

'計算結果シート⇒集計シートにコピー
    wks2.Range("A1:F" & rs.RecordCount).Copy Destination:=Sheets("実績集計").Range("A3")
ここでは、コピーをしているだけ。
オートフィルターの範囲内に張り付けている確認はどうされているのでしょう。
範囲外に値を張り付けている事はないのでしょうか?
 
 
1回目だけとなると、グラフィックボードの問題・・最新ドライバーのインストール、Excel UpDate
グラフィックアクセレーターの設定 いろいろなExcel以外の可能性もあるのですよね。
 
少なくとも、当方は、以前のスレッドまでさかのぼり、今回提示されたコードを見比べ
再現させようという気はおきません。
 
シングルステップでどうだったのですか?
オートフィルターの条件の取得方法は提示しました。参考になりませんでしたか?

投稿日時: 19/02/26 11:31:28
投稿者: FILETUBE

Suzuさん、回答ありがとうございます。
 ご指摘いただきました、シングルステップも
 フィルタの条件の取得も問題ありません。
 
 それなのにシートを移動させると1行違う行(フィルタ条件外の次の行)
  が表示されます。
 
 '計算結果シート⇒集計シートにコピー
 wks2.Range("A1:F" & rs.RecordCount).Copy Destination:=Sheets("払出実績集計").Range("A3")
  
 'この行をこの場所に追加しました。
 wks.Range("$A$2:$Q$336").AutoFilter Field:=3, Criteria1:="D5094"
 
 
 最後にフィルタを実行すればOKになりましたが
 どのような条件かは
 If wks.AutoFilterMode = True Then
       For I = 1 To wks.AutoFilter.Filters.Count
         If wks.AutoFilter.Filters(I).On Then
           Debug.Print wks.AutoFilter.Range(1, I) & vbTab & wks.AutoFilter.Filters(I).Criteria1
         End If
       Next I
 End If
 
 で確認はできましたが、どのように保存してフィルタを再実行するのかになります。
 今一度、ご教授いただけないでしょうか。
 
 どうぞ宜しくお願いします。
 
   

回答
投稿日時: 19/02/26 15:26:11
投稿者: Suzu

フィルタ云々の前にその動作は本当に正しいの?
 

引用:
For y = 2 To vLst
        If wks.Cells(y, 1).Value <> "" Then
            skey = wks.Cells(y, 1).Value & wks.Cells(y, 2).Value & _

から
ワークシート「実績集計」には、2行目からデータが入っているのでは?
 
 
引用:
'集計シートをクリア
    wks.Range("A3:P" & Rows.Count).ClearContents
      (中略)
    '計算結果シート⇒集計シートにコピー
    wks2.Range("A1:F" & rs.RecordCount).Copy Destination:=Sheets("実績集計").Range("A3")

なのに、3行目からのデータをクリアし、3行目から データを張り付ける。
良いのですか?

回答
投稿日時: 19/02/26 16:10:16
投稿者: Suzu

クリアする範囲としても、レコードセットのレコード数の範囲となりますが、良いのでしょうか?
 
ディクショナリ使ったり SQL使ったりと忙しそうなので。。すべてSQLで。。
 
このコードを書いているワークブックに、シート「元シート」がある。という前提で。。
 
 
とりあえず、動作確認はしましたが、バックアップを取って実行してみてください。
計算結果シートに SQLと、ディクショナリを使った結果と同等の物ができているはずです。
 
オートフィルターの部分は、
先に述べている通り、
・クリア範囲
・オートフィルター範囲
に問題がありそうです。
そのあたり回答者では判断できませんのでご確認ください。
 
 
Private Sub Sumple()
Dim wks As Worksheet
 
Dim cn As ADODB.Connection
Dim rs As Object
Dim strSQL As String
Dim i As Long
 
Set wks = ThisWorkbook.Worksheets("計算結果")
 
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Properties("Extended Properties") = "Excel 12.0 xml;HDR=YES;IMEX=1"
cn.Open ThisWorkbook.FullName
 
'*****************************************************************************
strSQL = strSQL & " SELECT A.項目1, A.項目2, A.項目3, A.項目4, A.項目5, A.数量, """" AS 空項目, B.入力値 FROM ("
strSQL = strSQL & " SELECT 項目1, 項目2, 項目3, 項目4, 項目5, SUM(数量) AS 数量 "
strSQL = strSQL & " FROM [元シート$] "
strSQL = strSQL & " GROUP BY 項目1, 項目2, 項目3, 項目4, 項目5) AS A "
strSQL = strSQL & " LEFT JOIN [実績集計$] AS B ON "
strSQL = strSQL & " A.項目1= B.項目1 AND A.項目2= B.項目2 AND A.項目3= B.項目3 AND "
strSQL = strSQL & " A.項目4= B.項目4 AND A.項目5= B.項目5 "
 
'*****************************************************************************
rs.Open strSQL, cn, adOpenKeyset, adLockReadOnly
 
'計算結果シートをクリア
wks.Cells.ClearContents
 
'計算結果シートにデータを出力する
For i = 1 To rs.Fields.Count - 1
  wks2.Cells(1, i) = rs.Fields(i - 1).Name
Next i
wks2.Range("A2").CopyFromRecordset rs
 
'後処理
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
End Sub

投稿日時: 19/02/27 00:28:29
投稿者: FILETUBE

回答ありがとうございます。
集計シートは見出しが2行なので
データにセットは3行目からになります。
SQL文でデータを取得していますが
見出しが1行目に来ます。
 
回答にありましたクリアの件ですが
データの範囲で構いません。
 
回答頂いたコードありがとうございます。
早速やってみたいと思います。
 

投稿日時: 19/02/27 15:49:04
投稿者: FILETUBE

他いろいろと試していてレコードセットを出力した
  計算結果シートを並び替えてから集計シートにコピーにしたら、
  正しく表示するようになりました。
  下記がソートの前後の部分です。
 
    
    '集計シートをクリア
    wks.Range("A3:P" & Rows.Count).ClearContents
    '計算結果シートをクリア
    wks2.Range("A1:F" & Rows.Count).ClearContents
    '計算結果シートにデータを出力する
    wks2.Range("A1").CopyFromRecordset rs
 
   '計算結果シート並べ替え
    ActiveWorkbook.Worksheets("計算結果").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("計算結果").Sort.SortFields.Add Key:=Range("A1:A" & rs.RecordCount), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("計算結果").Sort.SortFields.Add Key:=Range("B1:B" & rs.RecordCount), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("計算結果").Sort.SortFields.Add Key:=Range("C1:C" & rs.RecordCount), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("計算結果").Sort.SortFields.Add Key:=Range("D1:D" & rs.RecordCount), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    ActiveWorkbook.Worksheets("計算結果").Sort.SortFields.Add Key:=Range("E1:E" & rs.RecordCount), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("計算結果").Sort
        .SetRange Range("A1:F" & rs.RecordCount)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
     
    '計算結果シート⇒集計シートにコピー
    wks2.Range("A1:F" & rs.RecordCount).Copy Destination:=Sheets("実績集計").Range("A3")
 
  もっとチェックをしますが、どうしてかなと思います。
 
   

回答
投稿日時: 19/02/27 16:26:08
投稿者: Suzu

ソートしたら問題ない。
 
という事であれば、
ソート前のデータと、ソート後のデータで何が違うのかではないのでしょうか。
 
 
データもなにもわからないまま、推測だけで回答するのは疲弊します。
すいませんがこれまでとさせてください。
 
P.S. せっかくSQL使ってるのですから並べ替えもSQLで行えば良いのでは。

投稿日時: 19/02/27 18:29:45
投稿者: FILETUBE

 Suzuさん何度も回答ありがとうございます。
SQL文の方でORDER BY しているのですが。
全く不思議です。
 
最後に別スレの方が良いのかもしれませんが
VBAのSQL文で WHERE 項目1 LIKE 'A%'
としているのですが、項目1の最初の文字がアルファベット
ならOKにしたいのですが、どのような構文になるでしょうか?
 
申し訳ありません、今一度よろしくお願いします。

回答
投稿日時: 19/02/27 19:51:50
投稿者: Suzu

ORDER を確認できるまでのデータを用意しテストを行っていませんが
 
strSQL = strSQL & " SELECT A.項目1, A.項目2, A.項目3, A.項目4, A.項目5, A.数量, """" AS 空項目, B.入力値 FROM ("
strSQL = strSQL & " SELECT 項目1, 項目2, 項目3, 項目4, 項目5, SUM(数量) AS 数量 "
strSQL = strSQL & " FROM [元シート$] "
strSQL = strSQL & " WHERE [項目5] LIKE ""[a-z]%"" "
strSQL = strSQL & " GROUP BY 項目1, 項目2, 項目3, 項目4, 項目5 ) AS A "
strSQL = strSQL & " LEFT JOIN [実績集計$] AS B ON "
strSQL = strSQL & " A.項目1= B.項目1 AND A.項目2= B.項目2 AND A.項目3= B.項目3 AND "
strSQL = strSQL & " A.項目4= B.項目4 AND A.項目5= B.項目5 "
strSQL = strSQL & " ORDER BY A.項目1, A.項目2, A.項目3, A.項目4, A.項目5;"
 
こんなので良いのでは?
 
LIKEに関しては
 
【Like 抽出条件を使ってデータを探す】
https://support.office.com/ja-jp/article/like-%E6%8A%BD%E5%87%BA%E6%9D%A1%E4%BB%B6%E3%82%92%E4%BD%BF%E3%81%A3%E3%81%A6%E3%83%87%E3%83%BC%E3%82%BF%E3%82%92%E6%8E%A2%E3%81%99-65b07c8a-b314-435a-8b48-2b911856d4f9
 
【ワイルドカード文字の例】
https://support.office.com/ja-jp/article/%E3%83%AF%E3%82%A4%E3%83%AB%E3%83%89%E3%82%AB%E3%83%BC%E3%83%89%E6%96%87%E5%AD%97%E3%81%AE%E4%BE%8B-939e153f-bd30-47e4-a763-61897c87b3f4

投稿日時: 19/02/28 16:52:42
投稿者: FILETUBE

Suzuさん、何度も回答ありがとうございます。
 
LIKEの件はよく分りました。
 
LEFT JOINにするか、そのままでするか
今一度検証したいと思います。
 
今回はいろいろとありがとうございました。
 
一旦このスレッドは閉じますが
また宜しくお願いします。