-1

我希望你能帮忙。

我有一张“投标书”，里面有很多列。最后一列 (k) 将具有“可能”、“不太可能”或“无偏见”的值。然后我有另外三张纸，分别称为“可能”、“不太可能”和“无偏见”

我正在寻找的是一个宏，它在运行时会复制“tender”中所有行的内容，其中 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
4

1 回答 1

0

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

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
于 2013-11-08T21:43:14.617 回答