Question

我不确定我是否一直在搜索正确的问题...我有一个Excel工作簿，其中包含多个工作表，代表日历年的每个月。我希望能够根据某个列中是否满足条件，将数据从一个工作表连续复制到下个月的下一个工作表。

例如：

在工作表“May2017”中，列A-L包含要复制到“Jun2017”的数据。但是，只有在D列中的值=“库存”或“添加到库存”时才会复制数据行。如果列D中的数据更新，则在“Jun2017”表格上（值从“库存”更改为“已发布”），它将不再转移到“Jul2017”表。

我想对所有工作表执行此操作，从“Jan2017”表开始。

这可能吗？

我让它为二月份的数据工作。但是，当复制数据时，我在M列中的公式会被替换。

提前感谢您的任何帮助。

这是VBA代码：

子测试（） Dim ws1 As Worksheet，ws2 As Worksheet 昏暗作为范围，rngToCopy作为范围 Dim lastrow As Long '改变Sheet1和Sheet2以适应设置ws1 = ThisWorkbook.Worksheets（“Jan2017”）设置ws2 = ThisWorkbook.Worksheets（“Feb2017”）

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

也许你是在追求这样的事情：

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

跨月度标签填充数据

1 个答案: