毎月のタブにデータを取り込みます

Question

正しい質問を検索しているかどうかわかりません... Excelワークブック内に、暦年の各月を表す複数のワークシートがあります。私は、特定の列で基準が満たされている場合に基づいて、1つのワークシートから次の月の次の行にデータをコピーすることができます。例えば

：ワークシートで

"May2017"、列A-L "はJun2017" にコピーするデータを含みます。ただし、列D = "在庫"または "在庫に追加"の値の場合にのみ、データ行がコピーされます。列Dのデータが更新された場合、 "Jun2017"シート（値は "在庫"から "発行"に変更されます）では、 "Jul2017"シートに引き継がれなくなります。

「Jan2017」シートから始まる、すべてのワークシートでこれを実行したいと思います。

これは可能ですか？

私は2月のデータのために働いています。データがコピーされるときには、列Mにある式が置き換えられます。

ありがとうございました。ここで

は、VBAのコードです：

サブテスト（）ワークシート、 を合わせてロング 「変更のSheet1とSheet2のようレンジ、rngToCopyとしてレンジ 薄暗いLASTROWとしてワークシート 薄暗いRNGとしてWS2として 薄暗いWS1多分

With ws1 
    'assumung that your data stored in column A:B, Sheet1 
    lastrow = .Cells(.Rows.Count, "m").End(xlUp).Row 
    Set rng = .Range("A4:m" & lastrow) 
    'clear all filters 
    .AutoFilterMode = False 
    With rng 
     'apply filter 
     .AutoFilter Field:=13, Criteria1:=1 
     On Error Resume Next 
     'get only visible rows 
     Set rngToCopy = .SpecialCells(xlCellTypeVisible) 
     On Error GoTo 0 
    End With 
    'copy range 
    If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A4") 
    'clear all filters 
    .AutoFilterMode = False 
End With 
Application.CutCopyMode = False 
End Sub 

Answer 1

あなたはこのような何か後にしているWS1 = ThisWorkbook.Worksheets（ "Jan2017"） 設定WS2 = ThisWorkbook.Worksheets（ "Feb2017"）に設定します。

Option Explicit 

Sub test() 
    Dim monthsArr As Variant 
    Dim iMonth As Long 

    monthsArr = Array("Jan2017", "Feb2017", "Mar2017", "Apr2017", "Maj2017", "Jun2017", "Jul2017", "Aug2017", "Sep2017", "Oct2017", "Nov2017", "Dec2017") '<--| list your months tabs names 
    For iMonth = LBound(monthsArr) To UBound(monthsArr) - 1 '<--| loop from first to second to last month tab name 
     ProcessMonths CStr(monthsArr(iMonth)), CStr(monthsArr(iMonth + 1)) '<--| process the current "pair" of "first" and "subsequent" months 
    Next 
End Sub 

Sub ProcessMonths(month1 As String, month2 As String) 
    Dim ws1 As Worksheet, ws2 As Worksheet 
    Dim nFiltered As Long 
    Dim cellToPasteTo As Range 

    Set ws1 = ThisWorkbook.Worksheets(month1) 
    Set ws2 = ThisWorkbook.Worksheets(month2) 
    With ws1 '<--| reference "1st month" worksheet 
     .AutoFilterMode = False '<--| remove any previuous filtering 
     With .Range("D4", .Cells(.Rows.Count, "D").End(xlUp)) '<--| reference its column "D" cells from row 4 (header) down to last not empty one 
      .AutoFilter Field:=1, Criteria1:=Array("Inventory", "Add to Inventory"), Operator:=xlFilterValues '<--| filter referenced cells with "Inventory" or "Add to Inventory" content 
      nFiltered = Application.WorksheetFunction.Subtotal(103, .Cells) - 1 '<--| count filtered cells skipping header 
      If nFiltered > 0 Then '<--| if any filtered cells other than header 
       Set cellToPasteTo = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1) '<--| set destination cell as the first empty one in "2nd month" worksheet column A 
       With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<--| reference filtered referenced cells skipping header 
        .value = "Updated" '<--| change their value to "Updated" 
        Intersect(.Parent.Range("A:L"), .EntireRow).Copy cellToPasteTo '<--| copy their adjacent cells from columns A to L and paste them from destination cell downwards 
        Application.CutCopyMode = False '<--| release clipboard 
       End With 
      End If 
     End With 
     .AutoFilterMode = False '<--| remove filtering 
    End With 
End Sub