Excel VBA質問箱 IV

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

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


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

【30024】AdvancedFilter の使い方 琴葉 05/10/18(火) 15:06 質問[未読]
【30027】Re:AdvancedFilter の使い方 Kein 05/10/18(火) 16:06 回答[未読]
【30029】Re:AdvancedFilter の使い方 琴葉 05/10/18(火) 16:54 質問[未読]
【30038】Re:AdvancedFilter の使い方 Kein 05/10/18(火) 18:04 発言[未読]
【30124】Re:AdvancedFilter の使い方 琴葉 05/10/20(木) 9:36 質問[未読]
【30136】Re:AdvancedFilter の使い方 琴葉 05/10/20(木) 14:47 お礼[未読]

【30024】AdvancedFilter の使い方
質問  琴葉  - 05/10/18(火) 15:06 -

引用なし
パスワード
   ユーザーフォーム上のCombo科目.Textを含んだレコードを抽出したいのですが
うまくできません。

Sheets("2")をアクティブにして作業しています。(貼り付け先)

Private Sub CommandButton1_Click()

  Sheets("【仕訳帳】").Range("A2:G65536").AdvancedFilter Action:=xlFilterCopy, _
  criteriarange:=Combo科目.Text, CopyToRange:=Range("A2:G2"), Unique:=False
  
End Sub

---------------------------------------------------------------------------

 次の作業としてCombo科目.Textが 「現金」 と記入した場合、Sheets("2")のような表示にしようと考えています。
 これですと1列目の項目とデーターがA列、B列以外はあっていません。

Sheets("【仕訳帳】")コピー元データ
  A    B    C     D   E    F     G
1 日付 工事番号 借方金額 借方科目 摘要 貸方金額 貸方科目  
2 10/18  1   1000   現金   @  売上   1000
3 10/18  2    300   預金   @  現金   300
4 10/19  3   3000   売上   @  預金   3000
5 10-19  4   5000   現金   @  預金   5000  

Sheets("2")コピー先データ
  A    B    C     D   E    F   G    H    I
1 日付 工事番号 工事名 相手科目 摘要  科目 借方金額 貸方金額  残金
2 10/18  1   1000   現金   @  売上  1000
3 10/18  2    300   預金   @  現金  300
4 10-19  4   5000   現金   @  預金  5000  
5

上表を下表のようにするには、どうしたらよろしいでしょうか
何日かやっていますが全然解決しません、よろしくお願いいたします。


  A    B    C     D   E    F   G    H    I
1 日付 工事番号 工事名 相手科目 摘要  科目 借方金額 貸方金額  残金
2 10/18  1   1000   売上  @   現金   1000   0   1000
3 10/18  2    300   預金   @  現金    0   300   700
4 10-19  4   5000   預金   @  現金   5000   0   5700
5

【30027】Re:AdvancedFilter の使い方
回答  Kein  - 05/10/18(火) 16:06 -

引用なし
パスワード
   Findメソッドで一つずつ拾っていったら、どうでしょーか ?
フィルターを使うコードよりちょっと複雑になりますが、こんな感じです。

Private Sub CommandButton1_Click()
  Dim txt As String, Ad As String
  Dim FR As Range
  Dim RAry() As Long, i As Long

  txt = Combo科目.Text
  If txt = "" Then Exit Sub
  Application.ScreenUpdating = False
  Set FR = Sheets("【仕訳帳】").Range("A:I") _
  .Find(txt, , xlValues, xlWhole, , xlPrevious)
  If FR Is Nothing Then
   MsgBox "検索値が見つかりません", 48
   GoTo ELine
  Else
   Ad = FR.Address: i = 1
   ReDim RAry(i): RAry(i) = 0
   Sheets("Sheet2").Rows("2:65536").ClearContents
  End If
  Do
   Set FR = Sheets("【仕訳帳】").Range("A:I").FindNext(FR)
   If IsError(Application.Match(FR.Row, RAry, 0)) Then
     FR.EntireRow.Copy Sheets("Sheet2").Range("A65536") _
     .End(xlUp).Offset(1)
     i = i + 1: ReDim Preserve RAry(i): RAry(i) = FR.Row
   End If
  Loop Until FR.Address = Ad
  Sheets("Sheet2").Activate
  Set FR = Nothing: Erase RAry
ELine:
  Application.ScreenUpdating = True
  MsgBox "処理を終了します", 64
End Sub 

【30029】Re:AdvancedFilter の使い方
質問  琴葉  - 05/10/18(火) 16:54 -

引用なし
パスワード
   Kein さんありがとうございます。
うまくコピーできております^^ 私は3日間なやんで何もできませんでしたが・・・

あとよろしければ、シート2に抽出したデーターの並び替えの方法がわかりましたら
教えていただきたいのですが、よろしくお願いいたします。
(科目と相手科目が逆の場合があるので難しいです。)

【30038】Re:AdvancedFilter の使い方
発言  Kein  - 05/10/18(火) 18:04 -

引用なし
パスワード
   確かに
>科目と相手科目
に抽出した値があるようですが、どちらを基準にして並べ替えるのでしょーか ?
それを決めないことには回答できませんが・・。
ま、とにかく一度、Sortメソッドのヘルプを調べておいて下さい。
できるだけ自分で調べて、解決できた方がいいですから。

【30124】Re:AdvancedFilter の使い方
質問  琴葉  - 05/10/20(木) 9:36 -

引用なし
パスワード
   列の入替を下記のようにしてみたのですが最初のセルがCells(a, 6) = txt
ですとうまく動きません。どこがいけないのでしょうか

Private Sub Button集計_Click()

  a = 2
  Do While Cells(a, 6) = txt‘txt=combo科目.textです
    a = a + 1

    Do While Cells(a, 6) <> txt
      Cells(a, 4).Select ‘F1=txtでない場合F1とD1を入れ替える  
      Selection.Cut
      Cells(a, 10).Select
      ActiveSheet.Paste
      Cells(a, 6).Select
      Selection.Cut
      Cells(a, 4).Select
      ActiveSheet.Paste
      Cells(a, 10).Select
      Selection.Cut
      Cells(a, 6).Select
      ActiveSheet.Paste
      If Cells(a, 6).Value = "" Then Exit Do
      a = a + 1
    Loop
  Loop
  
End Sub
よろしくお願いいたします。

【30136】Re:AdvancedFilter の使い方
お礼  琴葉  - 05/10/20(木) 14:47 -

引用なし
パスワード
   下記のようにして解決いたしました。
何とか自分でがんばってみたのですが、もしおかしいところがありましたら教えてください。

a = 2
  Do
    If Cells(a, 6) = txt Then
      a = a + 1
    Else
      Cells(a, 4).Select
      Selection.Cut
      Cells(a, 10).Select
      ActiveSheet.Paste
      Cells(a, 6).Select
      Selection.Cut
      Cells(a, 4).Select
      ActiveSheet.Paste
      Cells(a, 10).Select
      Selection.Cut
      Cells(a, 6).Select
      ActiveSheet.Paste
      a = a + 1
    End If
  Loop While Cells(a, 6) <> ""

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