Question

我希望你能提供帮助。

我有一张“招标”，里面有很多栏目。最后一列（k）将具有“可能”，“不太可能”或“无偏见”的值。然后我又增加了三张，称为“可能”，“不太可能”和“没有偏见”

我正在寻找的是一个宏，在运行时，复制“招标”中所有行的内容，其中列k与相应的表匹配。即所有'可能'行都在'可能'表中，依此类推。

此外，每次运行宏时，我都需要在工作表中完全刷新信息。我已经看到其他请求，每次运行宏时都会向后续工作表添加新行但保留结果也是最后一次运行。我需要每次完全刷新后续工作表以允许对“招标”中的列k进行可能的更改

希望这是足够的信息，我是一个完整的新手，所以任何帮助表示赞赏

Sub LikelyTender()
Application.CutCopyMode = False

Dim r As Long, c As Long
Dim ws As Worksheet
Dim sType As String
Dim wsRow As Long

Worksheets("Overview").Activate
r = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row '
c = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column '
Range("A1").AutoFilter


For Each ws In Worksheets
    If ws.Name <> "Overview" Then
        '
        ws.Activate '
        wsRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 1 '
        sType = ws.Name '
        Worksheets("Overview").Activate '
        Range("J1:J" & r).AutoFilter Field:=10, Criteria1:=sType
        Range(Cells(2, 1), Cells(r, c)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A" & wsRow)
    End If
Next ws

Range("A1").AutoFilter

Application.CutCopyMode = True
End Sub

Answer 1

我在这里做了两个假设，（1）你的所有工作表都包含一个标题行，并且，（2）＆＃34;刷新＆＃34;您的工作表意味着清除标题行下方的所有先前数据编码时要避免的一件事是＆＃34;选择＆＃34;或＆＃34;激活＆＃34;一张纸或一个范围。很少需要，通常是不受欢迎的。如果我正确理解您的要求，此代码应该适合您。

Sub LikelyTender()

Dim rT As Range 'source data
Dim rD As Range 'data minus headers
Dim wS As Worksheet 'source sheet
Dim wT As Worksheet 'target sheet
Dim wsRow As Long
Dim b As Boolean

Set wS = Worksheets("Overview")
With wS
    .AutoFilterMode = False
    Set rT = .Range("A1", .Cells(1, Columns.Count).End(xlToLeft)) 'data width
    Set rT = rT.Resize(.Cells(.Rows.Count, 3).End(xlUp).Row) 'data height including header
    Set rD = rT.Offset(1).Resize(rT.Rows.Count - 1) 'data height wo header
End With

For Each wT In Worksheets
    rT.AutoFilter Field:=11, Criteria1:=wT.Name
    On Error Resume Next
    b = rD.SpecialCells(xlCellTypeVisible).Count > 1 'check if data for this sheet
    On Error GoTo 0
    If b Then 'data exists, continue
        wT.Range("A2", wT.Cells.SpecialCells(xlLastCell)).Clear 'clear everything below header row
' This next line may not be necessary if new data always placed at row 2
        wsRow = wT.Cells(Rows.Count, 2).End(xlUp).Row + 1 'find 1st empty row
        rD.SpecialCells(xlCellTypeVisible).Copy wT.Range("A" & wsRow) 'copy over data
    End If
Next wT
wS.AutoFilterMode = False
Application.CutCopyMode = False
End Sub

宏将工作表中的某些行复制到新工作表中，并每次刷新所有工作表

1 个答案: