Question

我需要VBA的帮助！

我有一本有10个工作表的工作簿。我想遍历前8个，并将某些值复制到第10个。

这是我到目前为止所做的：

Sub GetData()

Dim wbSource As Workbook
Dim wsTarget As Worksheet
Dim lastline As Integer


Set wbSource = ThisWorkbook 'everything will be from this workbook


Set wsTarget = wbSource.Sheets(10) 'wsTarget is my summary sheet, which is the the 10th tab




For x = 1 To 6
wsTarget.Range("H" & x).Value = wbSource.Sheets(1).Range("S" & x) 'copying over some info from the first sheet onto summary sheet, since this info will be the same on all sheets
Next x

For k = 1 To 8 ' sheet 10 is my summary sheet

Dim j As Integer 'this is a pointer that moves within each wsSource to look for values to be copied
Dim m As Integer 'this is the pointer that moves within the summary (wsTarget) sheets to paste values
j = 8 ' j amd m happen to be the same, coincidence
m = 8


For i = 1 To wbSource.Sheets(k).Range("X65536").End(xlUp).Row 'for each line in worksheet (k)


MatchCase = False 'do not match case
If wbSource.Sheets(k).Range("X" & j) = "y" Then ' if "Y/y" is found


lastline = wbSource.Sheets(k).Range("X65536").End(xlUp).Row
For a = 1 To lastline 'search until the spreadsheet is empty


If IsEmpty(wsTarget.Range("B" & m).Value) Then ' if this cell is empty, copy over the values from the wbSource, and here are the values to copy:


wsTarget.Range("B" & m).Value = wbSource.Sheets(k).Range("D" & j).Value 'exiting or new
wsTarget.Range("C" & m).Value = wbSource.Sheets(k).Range("I" & j).Value 'number
wsTarget.Range("D" & m).Value = wbSource.Sheets(k).Range("K" & j).Value 'title
wsTarget.Range("E" & m).Value = wbSource.Sheets(k).Range("P" & j).Value 'revision
wsTarget.Range("F" & m).Value = wbSource.Sheets(k).Range("Q" & j).Value 'status
wsTarget.Range("G" & m).Value = wbSource.Sheets(k).Range("R" & j).Value 'part of DOC number
wsTarget.Range("H" & m).Value = wbSource.Sheets(k).Range("U" & j).Value 'remarks
wsTarget.Range("I" & m).Value = wbSource.Sheets(k).Range("X" & j).Value 'confirmation


ElseIf Not IsEmpty(wsTarget.Range("B" & m).Value) Then 'if this cell already contains a value, move to next line
m = m + 1


End If


m = m + 1 'after a value has been pasted, move the next line
j = j + 1 'move to next line in wbSource worksheets




Next a ' next line in wbSource
Next i ' next line in wsTarget
Next k 'next workbook


End Sub

现在，当我尝试运行代码时，我收到一条错误消息“编译错误：下一个没有用于”，它突出显示下一个i。我究竟做错了什么？请帮忙！

如果您对如何提高我的代码效率有任何建议，请告诉我。我愿意接受建议。

提前致谢

Answer 1

你错过了End If。我对代码进行了一些修改，使其更加紧凑/高效。试一试：

Sub GetData()

    Dim wsTarget As Worksheet
    Dim rngFound As Range
    Dim arrData(1 To 65000, 1 To 8) As Variant
    Dim strFirst As String
    Dim DataIndex As Long
    Dim i As Long

    Set wsTarget = Sheets(10)   'wsTarget is my summary sheet, which is the the 10th tab
    wsTarget.Range("H1:H6").Value = Sheets(1).Range("S1:S6").Value  'Copying over some info from the first sheet onto summary sheet, since this info will be the same on all sheets

    For i = 1 To 8  'Loop through first 8 sheets
        'Look for Y/y in column X of the worksheet
        Set rngFound = Sheets(i).Columns("X").Find("y", Sheets(i).Cells(Rows.Count, "X"), xlValues, xlWhole)
        If Not rngFound Is Nothing Then
            'For each found Y, get corresponding information
            strFirst = rngFound.Address
            Do
                DataIndex = DataIndex + 1
                arrData(DataIndex, 1) = Sheets(i).Cells(rngFound.Row, "D").Text
                arrData(DataIndex, 2) = Sheets(i).Cells(rngFound.Row, "I").Text
                arrData(DataIndex, 3) = Sheets(i).Cells(rngFound.Row, "K").Text
                arrData(DataIndex, 4) = Sheets(i).Cells(rngFound.Row, "P").Text
                arrData(DataIndex, 5) = Sheets(i).Cells(rngFound.Row, "Q").Text
                arrData(DataIndex, 6) = Sheets(i).Cells(rngFound.Row, "R").Text
                arrData(DataIndex, 7) = Sheets(i).Cells(rngFound.Row, "U").Text
                arrData(DataIndex, 8) = Sheets(i).Cells(rngFound.Row, "X").Text
                Set rngFound = Sheets(i).Columns("X").Find("y", rngFound, xlValues, xlWhole)    'Find the next Y
            Loop While rngFound.Address <> strFirst
        End If
    Next i

    'Output results (if any)
    If DataIndex > 0 Then wsTarget.Cells(Rows.Count, "B").End(xlUp).Offset(1).Resize(DataIndex, UBound(arrData, 2)).Value = arrData

    Set wsTarget = Nothing
    Set rngFound = Nothing
    Erase arrData

End Sub

VBA：循环工作簿中的工作表以复制某些单元格中的值

1 个答案: