Question

我有两个工作簿 - 一个是需求，另一个是存储。我的目的是根据存储工作簿中的数量，类型和配置从需求工作簿中删除许多工具。删除的工具需要是截止日期最接近当前日期的工具。

例如，如果我在存储工作簿中有两个类型为Aleris 8500的工具，我会删除需求工作簿中的前两个即将推出的Aleris 8500工具。到目前为止，我只根据工具类型做了这个。现在我想添加第二个标准 - 工具的配置。我需要帮助，因为我是VBA的初学者。

要继续上一个示例，如果Aleris 8500的2个工具配置为150，我需要删除前两个即将推出的Aleris 8500工具。

Demand工作簿如下所示：

存储工作簿如下所示：

以下是我的代码，只根据工具类型删除：

Sub Demand_Minus_Storage()
  Dim QT As Long
  Dim i As Long

'open demand workbook
  Dim Demand_WB As Workbook
  Set Demand_WB = Workbooks.Open("C:\Users\rosipov\Desktop\eliran\MFG - GSS\Demand_Optics " & Format(Now(), "dd.mm.yyyy") & ".xlsx")

'open storage workbook
  Dim storage_wb As Workbook
  Set storage_wb = Workbooks.Open("C:\Users\rosipov\Desktop\eliran\MFG - GSS\OpticLabStorage.xlsm")




'now we romove from the demand what we already have in our storage


'Illuminators
Dim rngRow As Range

Demand_WB.Worksheets("Illuminators").Activate


  With storage_wb.Worksheets("Illuminator")
    For Each rngRow In .Range(.Rows(3), .Rows(WorksheetFunction.Match("*", .Range("A:A"), -1))).Rows
      With Worksheets("Illuminators").UsedRange.Offset(1)
        .Sort .Columns(5)
        .Offset(-1).AutoFilter Field:=5, Criteria1:="=" & rngRow.Cells(1) & "*"
        .Sort .Columns(2)
        With .SpecialCells(xlCellTypeVisible).EntireRow.Areas(1)
          Range(.Rows(1), .Rows(WorksheetFunction.Min(rngRow.Cells(3), .Rows.Count))).Delete
        End With
        .Offset(-1).AutoFilter
        .Sort .Columns(2)
      End With
    Next
  End With
  Cells(1).Select

End Sub

Answer 1

编辑： ^{_{（v0.1.1）错误修复以避免在数量为零时删除工具。}}

要添加第二个标准，您只需要一个额外的排序和一个额外的自动过滤器。

以下是您添加了修改的原始代码：

Sub Demand_Minus_Storage()
  'Dim QT As Long
  'Dim i As Long

'open demand workbook
  Dim Demand_WB As Workbook
  Set Demand_WB = Workbooks.Open("C:\Users\rosipov\Desktop\eliran\MFG - GSS\Demand_Optics " & Format(Now(), "dd.mm.yyyy") & ".xlsx")

'open storage workbook
  Dim storage_wb As Workbook
  Set storage_wb = Workbooks.Open("C:\Users\rosipov\Desktop\eliran\MFG - GSS\OpticLabStorage.xlsm")




'now we romove from the demand what we already have in our storage


'Illuminators
Dim rngRow As Range

Demand_WB.Worksheets("Illuminators").Activate


  With storage_wb.Worksheets("Illuminator")
    For Each rngRow In .Range(.Rows(3), .Rows(WorksheetFunction.Match("*", .Range("A:A"), -1))).Rows
      If rngRow.Cells(3) > 0 Then
        With Demand_WB.Worksheets("Illuminators").UsedRange.Offset(1)
          .Sort .Columns(6) ' BBSE
          .Sort .Columns(5) ' Tool Type
          .Offset(-1).AutoFilter Field:=5, Criteria1:="=" & rngRow.Cells(1)
          .Offset(-1).AutoFilter Field:=6, Criteria1:="=" & rngRow.Cells(2)
          .Sort .Columns(2) ' Due Date
          With .SpecialCells(xlCellTypeVisible).EntireRow.Areas(1)
            Range(.Rows(1), .Rows(WorksheetFunction.Min(rngRow.Cells(3), .Rows.Count))).Delete
          End With
          .Offset(-1).AutoFilter
          .Sort .Columns(2) ' Due Date
        End With
      End If
    Next
  End With
  Cells(1).Select

End Sub

我还添加了一个整洁且完整记录的版本：

Sub Demand_Minus_Storage()

  Const n_DemandHeaderRows As Long = 1
  Const i_SN_UTID   As Long = 1
  Const i_Due_Date  As Long = 2
  Const i_Tool_Type As Long = 5
  Const i_BBSE      As Long = 6
  Const n_StorageHeaderRows As Long = 2
  Const i_OpticLab_Tool_Type     As Long = 1
  Const i_OpticLab_Configuration As Long = 2
  Const i_OpticLab_QT            As Long = 3

  Dim ƒ As WorksheetFunction: Set ƒ = WorksheetFunction

  Dim storage_wb As Workbook
  Set storage_wb = Workbooks.Open("C:\Users\rosipov\Desktop\eliran\MFG - GSS\OpticLabStorage.xlsm")

  Dim Demand_WB As Workbook
  Set Demand_WB = Workbooks.Open("C:\Users\rosipov\Desktop\eliran\MFG - GSS\Demand_Optics " & Format(Now(), "dd.mm.yyyy") & ".xlsx")

  With storage_wb.Worksheets("Illuminator")
    ' Use the worksheet function "Match" to find the last storage used row
    ' Then loop through each storage row
    Dim rngRow As Range
    For Each rngRow In .Range(.Rows(n_StorageHeaderRows + 1), .Rows(ƒ.Match("*", .Columns(i_SN_UTID), -1))).Rows
      ' Only action tools with a quantity greater than zero
      If rngRow.Cells(i_OpticLab_QT) > 0 Then
        ' Skip the header rows and at the same time add at least one row after the end of the table
        With Demand_WB.Worksheets("Illuminators").UsedRange.Offset(n_DemandHeaderRows)
          ' Need to sort by BBSE and by tool type so the rows to be deleted are contiguous
          .Sort .Columns(i_BBSE)
          .Sort .Columns(i_Tool_Type)
          ' Back up to last header row and apply the filter
          ' Filter for the tool type that matches the tool type in the current storage row
          .Offset(-1).AutoFilter Field:=i_Tool_Type, Criteria1:="=" & rngRow.Cells(i_OpticLab_Tool_Type)
          ' Filter for the BBSE that matches the configuration in the current storage row
          .Offset(-1).AutoFilter Field:=i_BBSE, Criteria1:="=" & rngRow.Cells(i_OpticLab_Configuration)
          ' Need to re-sort by date as we previously sorted by tool type
          .Sort .Columns(i_Due_Date)
          ' Grab the first visible contiguous area. There is always at least the one from the row(s) after the end of the table.
          ' If there are any matching tools, these will form an area preceding the end of table area.
          With .SpecialCells(xlCellTypeVisible).EntireRow.Areas(1)
            ' Make sure we don't delete more rows than were actually found.
            ' If none were found, empty rows at the end of the table get deleted.
            Range(.Rows(1), .Rows(ƒ.Min(rngRow.Cells(i_OpticLab_QT), .Rows.Count))).Delete
          End With
          ' Turn autofilter off and show all hidden rows
          .Offset(-n_DemandHeaderRows).AutoFilter
          ' Need to re-sort by date as hidden rows were not sorted in previous date sort
          .Sort .Columns(i_Due_Date)
        End With
      End If
    Next
  End With
  ' Tidy up
  Cells(1).Select

End Sub

根据另一个表

1 个答案: