我有一张26页的工作簿。我想在这些表格的特定17页中扫描D列,从单元格" D15"开始。然而,这15张纸张按照增量顺序排列,即我希望在第4张和第20张纸之间进行扫描。
以下代码是我到目前为止,用户"餐饮主管"在上一个问题中,我开始使用它:Copy Paste macro is inducing 'grouped'-worksheet functionality?
Sub DSR_Autofill()
Variable Declarations:
Dim x_count As Long 'keeps track of how many "x"s you have
Dim i As Long 'for loop index
Dim n As Long 'while loop index
' Variable Initializations:
x_count = 0 'start x count at zero
' Clear Previous Data:
Sheets(2).Range("A25:A29").ClearContents 'Clears Summary Pages before scanning through
Sheets(3).Range("A18:A200").ClearContents
' Main Data Transfer Code:
For i = 5 To i = 20 'Starts at "Process Controls" and ends on "Product Stewardship"
Sheets(i).Select 'Select current indexed worksheet and...
Range("D15").Select '...the first item cell in the "Yes" Column
n = 0 'initialize n to start at top item row every time
Do While ActiveCell.Offset(n, -3) <> Empty 'Scan down "YES" column until Item Column (just A Column)...
'...has no characters in it (this includes space (" "))
Call Module2.algorithm(x_count, n) 'See subroutine code
Sheets(i).Select 'Return to frame of reference
Range("D15").Select
Loop 'syntax for continuation of while loop
i = i + 1
Next i 'syntax for continuation of for loop
If (x_count > 5) Then 'Bring user back to the Summary Page where...
'...the last Item was logged
Sheets("SUMMARY P.2").Select
Else
Sheets("SUMMARY P.1").Select
End If
End Sub
然后是算法代码:
Sub algorithm(x_count As Long, n As Long)
Dim item_a As String 'Letter part of Item
Dim item_b As String 'Number part of Item
'If an "x" or "X" is marked in the "Yes" column,
'at descending cells down the column offset by the for loop index, n
If (ActiveCell.Offset(n, 0) = "x" Or ActiveCell.Offset(n, 0) = "X") Then
item_a = ActiveCell.Offset(n, -3).Value ' Store Letter value
item_a = Replace(item_a, "(", "") ' Get rid of "(", ")", and " " (space)
item_a = Replace(item_a, ")", "") ' characters that are grabbed
item_a = Replace(item_a, " ", "")
item_b = ActiveCell.Offset(n, -2).Value ' Store number value
item_b = Replace(item_b, "(", "") ' Get rid of "(", ")", and " " (space)
item_b = Replace(item_b, ")", "") ' characters that are grabbed
item_b = Replace(item_b, " ", "")
x_count = x_count + 1 ' increment the total x count
If (x_count > 5) Then ' If there are more than 5 "x" marks,
Sheets("SUMMARY P.2").Activate ' then continue to log in SUMMARY P.2
Range("A18").Select ' Choose "Item" column, first cell
ActiveCell.Offset((x_count - 6), 0).Value = (item_a & item_b)
'Insert cocatenated value of item_a and item_b
'(for example "A" & "1" = "A1")
'at the cells under the "Item" column, indexed by x_count
Else ' If there are less than 5 "x" marks,
Sheets("SUMMARY P.1").Activate ' log in SUMMARY P.1
Range("A25").Select ' Choose "Item" column, first cell
ActiveCell.Offset((x_count - 1), 0).Value = (item_a & item_b)
End If
End If
n = n + 1
End Sub
答案 0 :(得分:2)
[编辑]:根据新信息更新了代码:
Sub DSR_Autofill()
Dim wsSummary1 As Worksheet
Dim wsSummary2 As Worksheet
Dim rngFound As Range
Dim arrSummary1(1 To 5) As String
Dim arrSummary2(1 To 65000) As String
Dim strFirst As String
Dim strTemp As String
Dim DataIndex1 As Long
Dim DataIndex2 As Long
Dim xCount As Long
Dim i As Long
Set wsSummary1 = Sheets("SUMMARY P.1")
Set wsSummary2 = Sheets("SUMMARY P.2")
wsSummary1.Range("A25:A29").ClearContents
wsSummary1.Range("A18:A" & Rows.Count).ClearContents
For i = Sheets("Process Controls").Index To Sheets("Product Stewardship").Index
With Sheets(i).Range("D15", Sheets(i).Cells(Rows.Count, "D").End(xlUp))
Set rngFound = .Find("x", .Cells(.Cells.Count), xlValues, xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
strTemp = Replace(Replace(Replace(Sheets(i).Cells(rngFound.Row, "A").Text & Sheets(i).Cells(rngFound.Row, "B").Text, "(", ""), ")", ""), " ", "")
If xCount < 5 Then
DataIndex1 = DataIndex1 + 1
arrSummary1(DataIndex1) = strTemp
Else
DataIndex2 = DataIndex2 + 1
arrSummary2(DataIndex2) = strTemp
End If
xCount = xCount + 1
Set rngFound = .Find("x", rngFound, xlValues, xlWhole)
Loop While rngFound.Address <> strFirst
End If
End With
Next i
If DataIndex1 > 0 Then wsSummary1.Range("A25").Resize(DataIndex1).Value = Application.Transpose(arrSummary1)
If DataIndex2 > 0 Then wsSummary2.Range("A18").Resize(DataIndex2).Value = Application.Transpose(arrSummary2)
If xCount > 5 Then wsSummary2.Select Else wsSummary1.Select
End Sub