[[20220903185452]]　『取込むExcelの日付をフィルタし、取込み先にシーメx（初心者）　ページの最後に飛ぶ

『取込むExcelの日付をフィルタし、取込み先にシートをつくり、転記する。』（初心者）

取込むExcelの日付をフィルタし、
取込み先に取り込んだ年・月シートを新たにつくり、そこへ取り込むマクロを作りたいです。

フィルターと転記部分がわからず、ご助言を頂けないでしょうか。
お願いいたします。

Option Explicit

Sub ボタン4_Click()

Dim filePath As Variant
Dim wb1 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim Sname As String
Dim twb As Workbook, x

    x = 0

'記入用シートをコピーし、シート名を年と月をと名付ける'

    Set twb = ThisWorkbook
    Set ws2 = twb.Worksheets("記入用")
    Set ws3 = twb.Worksheets("操作画面")
    Sname = StrConv(Format(Date + x, "yyyy.m"), vbWide)
    If Evaluate("=ISREF(" & Sname & "!A1)") Then
        Application.DisplayAlerts = False
        twb.Worksheets(Sname).Delete
        Application.DisplayAlerts = True
    End If
    ws1.Copy before:=ws3
    Set ws4 = twb.ActiveSheet
    With ws4
        With .Range("F3")
            .Value = Date
            .Font.Size = 24
        End With
        .Name = Sname
    End With

'Excelを取込み、取込みExcelのB4列の日付を今日以降のデータをフィルタし、転記する。'

ChDir ThisWorkbook.Path
'---- ファイル参照ダイアログの表示 ----
filePath = Application.GetOpenFilename(FileFilter:="xlsxファイル(*.xlsx),*.xlsx", _
Title:="xlsxファイルの選択")
If filePath = False Then
MsgBox "ファイルが選択されなかったので処理を中止します。"
Exit Sub
End If

If wb1 Is Nothing Then
Set wb1 = Workbooks.Open(filePath)
End If
Set ws1 = wb1.Worksheets(1)

Dim d As Date
Dim i As Long
Dim cnt1 As Integer
d = Format(Date, "yyyy/m/d")

 ws1.Range(“B4″).CurrentRegion.AutoFilter field:=1, Criteria1:=">=" & d,

    For i = 4 To ws1.Cells(Rows.Count, "B").End(xlUp).Row
      cnt1 = 6
               ws4.Cells(cnt1, "B").Value = ws1.Cells(i, "B").Value
               ws4.Cells(cnt1, "C").Value = ws1.Cells(i, "C").Value
               ws4.Cells(cnt1, "D").Value = ws1.Cells(i, "D").Value
               ws4.Cells(cnt1, "E").Value = ws1.Cells(i, "E").Value
               ws4.Cells(cnt1, "F").Value = ws1.Cells(i, "F").Value
               ws4.Cells(cnt1, "G").Value = ws1.Cells(i, "G").Value
               ws4.Cells(cnt1, "H").Value = ws1.Cells(i, "H").Value
               ws4.Cells(cnt1, "I").Value = ws1.Cells(i, "I").Value
               ws4.Cells(cnt1, "J").Value = ws1.Cells(i, "J").Value
               ws4.Cells(cnt1, "K").Value = ws1.Cells(i, "K").Value

            cnt1 = cnt1 + 1
       Next i

      wb1.Close
      ws4.Select

End Sub

＜使用 Excel：Excel2016、使用 OS：Windows8 ＞

余計なお世話かもしれませんが、このトピックで最初に提示されたコードですと↓でエラーになりませんか？

 ws1.Copy before:=ws3

（もこな２） 2022/09/03(土) 20:34

■１
＞フィルターと転記部分がわからず
話がよく見えません。
気になる部分はあるものの、コード中で既に、【オートフィルタ】を設定していたり【転記】とみられる動作の記述がありますよね？
提示したコードをご自身で書いたのであれば既に方法はご存じなのでは？
なお、ご自身で作ったのでなければ、まずは【ステップ実行】などをして、コードの研究（理解）から手を付けてみるとよいとおもいます。

■２
新しい質問をするのも結構ですが、同時進行すると混乱してかえって理解が難しくなりませんか？
さらに、ほかのトピックと同じ失敗を繰り返すことにもなりかねませんから、1つずつ解決していかれてはどうですか？

■３
とりえず、このトピックに提示されたコードが見づらいので整理してみました。
（なお、直しましたが実際に間違っているのか投稿時のタイプミスかわからなくなるので、提示される場合はVBEから直接コピペすることをお勧めします。）

このほか、以下は完成品のプレゼントを意図したものではありません。
よって、研究の上必要な部分だけご自身のコードに組み込んでください。（理解せず丸パクリして完成！というのはご遠慮ください。）

    Sub 整理()
        Dim Sname As String
        Dim ws4 As Worksheet
        Dim filePath  As String
        Dim wb1 As Workbook
        Dim MyRNG As Range

        Stop 'ブレークポイントの代わり

        Sname = StrConv(Format(Date, "yyyy.m"), vbWide)

        On Error Resume Next
        Set ws4 = ThisWorkbook.Worksheets(Sname)
        On Error GoTo 0

        '▼該当シートの有無で処理分岐
        If ws4 Is Nothing Then
            ThisWorkbook.Sheets("記入用").Copy before:=ThisWorkbook.Sheets("操作画面")
            Set ws4 = ThisWorkbook.Sheets("操作画面").Previous
            ws4.Name = Sname
            ws4.Range("F3").Font.Size = 24
        End If

        ChDir ThisWorkbook.Path
        filePath = Application.GetOpenFilename(FileFilter:="xlsxファイル(*.xlsx),*.xlsx", Title:="xlsxファイルの選択")
        If filePath = "False" Then
            MsgBox "ファイルが選択されなかったので処理を中止します。"
            Exit Sub
        Else
            Set wb1 = Workbooks.Open(filePath)
        End If

        ws4.Range("F3").Value = Date

        With wb1.Worksheets(1)
            .AutoFilterMode = False
            .Range("B4").AutoFilter Field:=1, Criteria1:=">=" & Date

            '▼想像で変更
            Set MyRNG = Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(1))
            If Not MyRNG Is Nothing Then
                Intersect(MyRNG, .Range("B:K")).Copy
                ws4.Range("B6").PasteSpecial Paste:=xlPasteValues
            End If
        End With

        wb1.Close
        ws4.Select
    End Sub

（もこな２） 2022/09/03(土) 21:15

＞もこな２さま

ありがとうございます。
コードを研究してみます。

Excel取込み元であるエウセルは、データを読み取ったあと、
データを保存しますか？と問い合わせが有るのですが、
これは、オートフィルタ解除で対応出来ますでしょうか。
（初心者） 2022/09/04(日) 07:57

■４
＞これは、オートフィルタ解除で対応出来ますでしょうか。
聞く前に試してみましょう。

ちなみに、【閉じるときに】【保存せず】ブックを閉じればよいと思いますよ。

（もこな２） 2022/09/04(日) 12:09

プログラムコードを簡素化したいです。

Sub 整理()

        Dim Sname As String
        Dim Sname2 As String
        Dim ws1 As Worksheet
        Dim ws4 As Worksheet
        Dim filePath  As String
        Dim wb1 As Workbook
        Dim MyRNG As Range

        'Stop 'ブレークポイントの代わり

        Sname = StrConv(Format(Date, "yyyy.m"), vbWide)
        On Error Resume Next
        Set ws4 = ThisWorkbook.Worksheets(Sname)
        On Error GoTo 0

        '▼該当シートの有無で処理分岐
        If ws4 Is Nothing Then
            ThisWorkbook.Sheets("記入用").Copy before:=ThisWorkbook.Sheets("操作画面")
            Set ws4 = ThisWorkbook.Sheets("操作画面").Previous
            ws4.Name = Sname
            ws4.Range("F3").Font.Size = 24
        End If
        ChDir ThisWorkbook.Path
        filePath = Application.GetOpenFilename(FileFilter:="xlsxファイル(*.xlsx),*.xlsx", Title:="xlsxファイルの選択")
        If filePath = "False" Then
            MsgBox "ファイルが選択されなかったので処理を中止します。"
            Exit Sub
        Else
            Set wb1 = Workbooks.Open(filePath)
            Set ws1 = wb1.Worksheets(1)

        End If

        Sname2 = StrConv(Format(Date, "  (yyyy.m.dd)"), vbWide)
        ws4.Range("F3").Value = Sname2

        With wb1.Worksheets(1)
            .AutoFilterMode = False
            .Range("B4").AutoFilter Field:=1, Criteria1:=">=" & Date

            '▼想像で変更
            Set MyRNG = Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(1))
            If Not MyRNG Is Nothing Then
                Intersect(MyRNG, .Range("B:K")).Copy

↑

  ws4.Cells(b, "L").Value = ws1.Cells(a, "M").Value”書き方がどうしたら良いか分からないです。”

                ws4.Range("B6").PasteSpecial Paste:=xlPasteValues
            End If

           .ShowAllData

        End With

        ▼条件で変更

        Dim a As Long
        Dim b As Long
        Dim c As Long

        For a = 5 To ws1.Cells(Rows.Count, "B").End(xlUp).Row

          If InStr(Range("B" & a).Value, "年会費") > 0 Then

            b = ws4.Cells(Rows.Count, "B").End(xlUp).Row + 1

            ws4.Cells(b, "B").Value = ws1.Cells(a, "B").Value
            ws4.Cells(b, "C").Value = ws1.Cells(a, "C").Value
            ws4.Cells(b, "D").Value = ws1.Cells(a, "D").Value
            ws4.Cells(b, "E").Value = ws1.Cells(a, "E").Value
            ws4.Cells(b, "F").Value = ws1.Cells(a, "F").Value
            ws4.Cells(b, "G").Value = ws1.Cells(a, "G").Value
            ws4.Cells(b, "H").Value = ws1.Cells(a, "H").Value
            ws4.Cells(b, "I").Value = ws1.Cells(a, "I").Value
            ws4.Cells(b, "J").Value = ws1.Cells(a, "J").Value
            ws4.Cells(b, "K").Value = ws1.Cells(a, "K").Value
            ws4.Cells(b, "L").Value = ws1.Cells(a, "M").Value
       b = b + 1

     ElseIf InStr(Range("B" & a).Value, "未定") > 0 Then

       c = ws4.Cells(Rows.Count, "B").End(xlUp).Row + 1

       ws4.Cells(c, "B").Value = ws1.Cells(a, "B").Value
       ws4.Cells(c, "C").Value = ws1.Cells(a, "C").Value
       ws4.Cells(c, "D").Value = ws1.Cells(a, "D").Value
       ws4.Cells(c, "E").Value = ws1.Cells(a, "E").Value
       ws4.Cells(c, "F").Value = ws1.Cells(a, "F").Value
       ws4.Cells(c, "G").Value = ws1.Cells(a, "G").Value
       ws4.Cells(c, "H").Value = ws1.Cells(a, "H").Value
       ws4.Cells(c, "I").Value = ws1.Cells(a, "I").Value
       ws4.Cells(c, "J").Value = ws1.Cells(a, "J").Value
       ws4.Cells(c, "K").Value = ws1.Cells(a, "K").Value
       ws4.Cells(c, "L").Value = ws1.Cells(a, "M").Value
       c = c + 1
   End If

 Next a

        Application.DisplayAlerts = False
        wb1.Close
        Application.DisplayAlerts = True
        ws4.Select

End Sub
（初心者） 2022/09/04(日) 21:20

■５
＞コードを研究してみます。
＞プログラムコードを簡素化したいです。
いや、研究はどうなったんですか？コメントなども含めて私が提示したコードほぼそのままじゃないですか・・・・

■６
↓も意味がわかりません。

 ws4.Cells(b, "L").Value = ws1.Cells(a, "M").Value”書き方がどうしたら良いか分からないです。”

■７

        For a = 5 To ws1.Cells(Rows.Count, "B").End(xlUp).Row
          If InStr(Range("B" & a).Value, "年会費") > 0 Then
            b = ws4.Cells(Rows.Count, "B").End(xlUp).Row + 1
            ws4.Cells(b, "B").Value = ws1.Cells(a, "B").Value
            ws4.Cells(b, "C").Value = ws1.Cells(a, "C").Value
            ws4.Cells(b, "D").Value = ws1.Cells(a, "D").Value
            ws4.Cells(b, "E").Value = ws1.Cells(a, "E").Value
            ws4.Cells(b, "F").Value = ws1.Cells(a, "F").Value
            ws4.Cells(b, "G").Value = ws1.Cells(a, "G").Value
            ws4.Cells(b, "H").Value = ws1.Cells(a, "H").Value
            ws4.Cells(b, "I").Value = ws1.Cells(a, "I").Value
            ws4.Cells(b, "J").Value = ws1.Cells(a, "J").Value
            ws4.Cells(b, "K").Value = ws1.Cells(a, "K").Value
            ws4.Cells(b, "L").Value = ws1.Cells(a, "M").Value
       b = b + 1
     ElseIf InStr(Range("B" & a).Value, "未定") > 0 Then
       c = ws4.Cells(Rows.Count, "B").End(xlUp).Row + 1
       ws4.Cells(c, "B").Value = ws1.Cells(a, "B").Value
       ws4.Cells(c, "C").Value = ws1.Cells(a, "C").Value
       ws4.Cells(c, "D").Value = ws1.Cells(a, "D").Value
       ws4.Cells(c, "E").Value = ws1.Cells(a, "E").Value
       ws4.Cells(c, "F").Value = ws1.Cells(a, "F").Value
       ws4.Cells(c, "G").Value = ws1.Cells(a, "G").Value
       ws4.Cells(c, "H").Value = ws1.Cells(a, "H").Value
       ws4.Cells(c, "I").Value = ws1.Cells(a, "I").Value
       ws4.Cells(c, "J").Value = ws1.Cells(a, "J").Value
       ws4.Cells(c, "K").Value = ws1.Cells(a, "K").Value
       ws4.Cells(c, "L").Value = ws1.Cells(a, "M").Value
       c = c + 1
   End If
 Next a

上記の部分はどうしても１セルずつ転記したいのですか？
B列に"年会費"か"未定"が含まれるものを抽出した結果を「 ws4.Cells(Rows.Count, "B").End(xlUp).offset(1)」に値貼り付けすれば事足りませんか？

（もこな２） 2022/09/05(月) 17:23

コメント返信：

[ 一覧(最新更新順) ]

[[20220903185452]] 『取込むExcelの日付をフィルタし、取込み先にシーメx（初心者） ページの最後に飛ぶ

[[20220903185452]]　『取込むExcelの日付をフィルタし、取込み先にシーメx（初心者）　ページの最後に飛ぶ