-1

お役に立てれば幸いです。

いくつかの列を持つシート「テンダー」があります。最後の列 (k) には、「可能性が高い」、「可能性が低い」、または「バイアスなし」のいずれかの値が含まれます。次に、「可能性が高い」、「可能性が低い」、「バイアスなし」という 3 つのシートを追加します。

私が探しているのは、実行時に、列 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) シートを「更新」するということは、見出し行の下の以前のデータをすべてクリアするという 2 つの前提を置いています。コーディング時に避けるべきことの 1 つは、シートまたは範囲を「選択」または「アクティブ化」することです。必要になることはほとんどなく、通常は望ましくありません。私があなたの要件を正しく理解していれば、このコードはうまくいくはずです。

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 に答える