Excel VBA質問箱 IV

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

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


9829 / 76734 ←次へ | 前へ→

【72462】Re:転記したい
発言  Yuki  - 12/8/13(月) 16:51 -

引用なし
パスワード
   ▼うさこ さん:
横から失礼
AutoFilterで年月日の月データを表示するには
下記のようにします。
サンプルをあげておきます。
Sheet1はデータ
Sheet2からは抽出データ

Sub Macro1()
  Dim lCol  As Long
  Dim lPage  As Long
  Dim sht   As Worksheet
  Dim i    As Long
  Dim sS   As String
  Dim sE   As String
  Dim inPage As Long
  
  sS = InputBox("処理開始年月日を入力", "処理開始年月日", DateSerial(Year(Date), Month(Date), 1))
  sE = DateSerial(Year(CDate(sS)), Month(CDate(sS)) + 1, 1 - 1)
  
  inPage = 5 '区切りの列数
  With Worksheets("Sheet1")
    lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    lPage = Fix((lCol - 2) / inPage + 0.999999)  'シート数
    .AutoFilterMode = False
    With .Range("A1").CurrentRegion
      .AutoFilter Field:=1, Criteria1:=">=" & sS, Operator:=xlAnd, _
                 Criteria2:="<=" & sE
      For i = 1 To lPage
        ' シートの有無の確認         
        On Error Resume Next
        Set sht = Worksheets("Sheet" & i + 1)
        If Err.Number <> 0 Then
          ' 無かった追加
          Set sht = Worksheets.Add(After:=Worksheets(Worksheets.Count))
          sht.Name = "Sheet" & i + 1
        End If
        sht.Cells.Clear
        Set sht = Nothing
        .SpecialCells(xlCellTypeVisible).Copy _
          Worksheets("Sheet" & i + 1).Range("A1")
        
        With Worksheets("Sheet" & i + 1)
          .Columns(i * inPage + 3).Resize(, inPage * (lPage - 1)).Delete
          .Columns(3).Resize(, (i - 1) * inPage).Delete
        End With
      Next
    End With
    .AutoFilterMode = False
  End With
End Sub

5 hits

【72452】転記したい うさこ 12/8/13(月) 12:01 質問
【72454】Re:転記したい UO3 12/8/13(月) 14:08 発言
【72455】Re:転記したい うさこ 12/8/13(月) 14:13 質問
【72456】Re:転記したい UO3 12/8/13(月) 14:27 発言
【72457】Re:転記したい UO3 12/8/13(月) 14:29 発言
【72458】Re:転記したい うさこ 12/8/13(月) 14:57 質問
【72461】Re:転記したい うさこ 12/8/13(月) 16:36 質問
【72462】Re:転記したい Yuki 12/8/13(月) 16:51 発言
【72465】Re:転記したい UO3 12/8/13(月) 17:19 発言
【72467】Re:転記したい UO3 12/8/13(月) 17:36 発言
【72468】Re:転記したい kanabun 12/8/13(月) 17:50 発言
【72469】Re:転記したい うさこ 12/8/13(月) 18:31 お礼

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