1

私は頭がおかしくなっていますが、ここで何が間違っているのかわかりませんが、このマクロを実行するたびに、列ヘッダーと実際のデータの間に空白行が表示され続けます. 返されるデータは正しいのですが、上部に余分な行が表示される理由がわかりません!

新鮮な目をお願いします！

ありがとう

Dim LSearchRow As Long
Dim LCopyToRow As Long
Dim wks As Worksheet
On Error GoTo Err_Execute

For Each wks In Worksheets

LSearchRow = 4
LCopyToRow = 4

ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
Set wksCopyTo = ActiveSheet
wks.Rows(3).EntireRow.Copy wksCopyTo.Rows(3)

While Len(wks.Range("A" & CStr(LSearchRow)).Value) > 0

    If wks.Range("AB" & CStr(LSearchRow)).Value = "Yes" And wks.Range("AK" & CStr(LSearchRow)).Value = "Yes" And wks.Range("BB" & CStr(LSearchRow)).Value = "Y" Then

        Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
        Selection.Copy


        wksCopyTo.Select
        wksCopyTo.Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
        wksCopyTo.Paste

        'Move counter to next row
        LCopyToRow = LCopyToRow + 1
        'Go back to Sheet1 to continue searching
        wks.Select
    End If
    LSearchRow = LSearchRow + 1
Wend

Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Next wks
    Exit Sub
Err_Execute:
    MsgBox "An error occurred."
4

2 に答える 2

2

新鮮な目をお願いします！

たぶん、前にワークシート名が欠落しているからRows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Selectですか？

コードがこの行を実行した後

ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)

現在のシートは新しいシートであるため、新しく作成されたシートを参照します。その後、wks.Selectコントロールをメインシートに戻します。

だからそれを

wks.Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select

また、サブ全体を ( UNTESTED )として書き直すこともできます。

Option Explicit

Sub Sample()
    Dim LSearchRow As Long, LCopyToRow As Long
    Dim wks As Worksheet, wksCopyTo As Worksheet

    On Error GoTo Err_Execute

    For Each wks In Worksheets
        LSearchRow = 4: LCopyToRow = 4

        With wks
            ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
            Set wksCopyTo = ActiveSheet
            .Rows(3).EntireRow.Copy wksCopyTo.Rows(3)

            While Len(Trim(.Range("A" & LSearchRow).Value)) > 0
                If .Range("AB" & LSearchRow).Value = "Yes" And _
                   .Range("AK" & LSearchRow).Value = "Yes" And _
                   .Range("BB" & LSearchRow).Value = "Y" Then

                    .Rows(LSearchRow).Copy wksCopyTo.Rows(LCopyToRow)

                    LCopyToRow = LCopyToRow + 1
                End If
                LSearchRow = LSearchRow + 1
            Wend
        End With

        MsgBox "All matching data has been copied."
    Next wks

    Exit Sub

Err_Execute:
    MsgBox "An error occurred."
End Sub
于 2012-05-14T18:00:43.190 に答える
0

シッダールスが正しいと言ったのは、前にワークシート名が欠落しているためかもしれません...

コードはに設定wksCopyToされActiveSheet、データをテストしてから、wksから選択してコピーしActiveSheetます。whileループの後半で、それが選択しますwks-そのため、最初の行だけが空白になります

これらの5行を次のように変更します

wks.Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).copy wksCopyTo.Rows(CStr(LCopyToRow) & ":" & Str(LCopyToRow))
于 2012-05-14T19:48:48.953 に答える