-1

タスクを追跡するためにMicrosoftExcelを使用しています。私は仕事ごとに異なる「シート」を使用します。構造は列とデータに関するものです。私は次のことを実現するVBAスクリプトを作成しようとしています。

  1. シート1-Xを検索して、「Open」または「PastDue」の値を続けて検索します
  2. これらの値を持つすべての行を、行3から始まる単一のシート（元帳など）にコピーします（テンプレートのヘッダーを追加できるようにします）
  3. シート名を列Aに追加して、それがどのジョブから来たのかがわかるようにします。
  4. これを私の心に実行して、新しいアイテムで更新する強迫性行動の喜び

私は私を導くのを助けるために次の投稿を使用しています：

最後の2晩は楽しかったですが、これを必要以上に難しくしているように感じます。

すべてのワークシートをスイープするVBAスクリプト（ここの別の投稿から編集）を作成することはできましたが、一連の列のすべてのデータをコピーするように設計されていました。私はそれをテストしました、そしてそれは働きました。次に、列C（アクティブシートでのみ機能）の「Open」または「PastDue」を識別するために使用していたコードベースをコードにマージしました。ここで共有するために編集内容をマークアップしました。この時点では機能しておらず、めまいがします。コードをどこでfubarしたかについてのヒントをいただければ幸いです。私が働いているコードベースは次のとおりです。

Sub SweepSheetsCopyAll()

    Application.ScreenUpdating = False
   'following variables for worksheet loop
    Dim W As Worksheet, r As Single, i As Single
   'added code below for finding the fixed values on the sheet
    Dim lastLine As Long
    Dim findWhat As String
    Dim findWhat1 As String
    Dim findWhat2 As String
    Dim toCopy As Boolean
    Dim cell As Range
    Dim h As Long 'h replaced i variable from other code
    Dim j As Long

    'replace original findWhat value with new fixed value

    findWhat = "Open"
    'findWhat2 = "Past Due"


    i = 4
    For Each W In ThisWorkbook.Worksheets
        If W.Name <> "Summary" Then
           lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop all rows in a sheet to find last line
            For r = 4 To lastLine 'formerly was "To W.Cells(Rows.Count, 1).End(xlUp).Row"
                'insert below row match search copy function
                For Each cell In Range("B1:L1").Offset(r - 1, 0)
                   If InStr(cell.Text, findWhat) <> 0 Then
                      toCopy = True
                   End If
               Next
            If toCopy = True Then
    ' original code               Rows(r).Copy Destination:=Sheets(2).Rows(j)
     Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
                        ThisWorkbook.Worksheets("Summary").Cells(i, 1)
                j = j + 1
            End If
            toCopy = False
        'Next

                'end above row match search function
                'below original code that copied everything from whole worksheet
         '       If W.Cells(r, 1) > 0 Then
   '                 Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
    '                    ThisWorkbook.Worksheets("Summary").Cells(i, 1)
          '          i = i + 1
           '     End If
            Next r
        End If
    Next W
End Sub

すべてのシートをスイープするための作業コードベースは次のとおりです。

Sub GetParts()
    Application.ScreenUpdating = False
    Dim W As Worksheet, r As Single, i As Single
    i = 4
    For Each W In ThisWorkbook.Worksheets
        If W.Name <> "Summary" Then
            For r = 4 To W.Cells(Rows.Count, 1).End(xlUp).Row
                If W.Cells(r, 1) > 0 Then
                    Range(W.Cells(r, 1), W.Cells(r, 3)).Copy _
                        ThisWorkbook.Worksheets("Summary").Cells(i, 1)
                    i = i + 1
                End If
            Next r
        End If
    Next W
End Sub

そして、Activesheetから一致したデータをコピーするのは次のとおりです。

Sub customcopy()

Application.ScreenUpdating = False
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long

'replace original findWhat value with new fixed value

findWhat = "Open"
'findWhat2 = "Past Due"

lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop through all sheets here

'below code does nice job finding all findWhat and copying over to spreadsheet2
j = 1
For i = 1 To lastLine
    For Each cell In Range("B1:L1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(2).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next

i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")

Application.ScreenUpdating = True
End Sub
4

1 に答える 1

0

テーブルの値が条件を満たしている場合は、この Vba マクロを調べて、テーブルから行をコピーする必要があります

あなたの場合、この高度なフィルターを使用してループを作成し、データをターゲット範囲または配列にコピーする必要があります。

さらにアドバイスが必要な場合は、コードとどこに引っかかっているかを投稿してください。

于 2012-09-25T22:08:51.853 に答える