In the following program, what I am trying to do is scan the "yes" column of a specific range of sheets in a workbook that a user fills out, and wherever the user puts an "x" within that specific "Yes" column range, it will identify the associated item of the question marked in that row and copy the item code associated with that question (e.g. C3) into a Summary page for logging purposes.
The problem is that the code does not copy the item onto the summary page as intended when the for loop iterates through the desired range of sheets. However, if I comment out the for loop code and write Sheets(6).Select instead of Sheets(i).Select, for example, it will copy the "x" marked items onto the summary page for sheet index #6 as intended. This leads me to believe my copy+paste part of the code works (between the while loop statements), but the for loop fails somehow.
Can somebody please help me identify the source of the error? I understand that this code is not efficient, such as the excessive use of .select and non-dynamic declarations, but if I wanted to keep as much of the code the same as possible, how could I modify it to make it loop through all the sheets as I intended?
Thanks
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
Dim item_a As String 'Letter part of Item
Dim item_b As String 'Number part of Item
' Variable Initializations:
x_count = 0 'start x count at zero
' Clear Previous Data:
Sheets(2).Range("A25:A29").ClearContents 'Clear Summary Pages before scanning through
Sheets(3).Range("A18:A200").ClearContents
' Main Data Transfer Code:
For i = 5 To i = 20 'Starts at "Process Control" 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 (" "))
If (ActiveCell.Offset(n, 0) = "x" _
Or ActiveCell.Offset(n, 0) = "X") Then 'If an "x" or "X" is marked in the "YES" column at descending...
'...cells down the column, at an offset specified by the for loop index n
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 and...
Range("A18").Select ' ...choose "Item" column, first cell
ActiveCell.Offset((x_count - 6), 0).Value = (item_a & item_b)
'Insert concatenated 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 and...
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
Sheets(i).Select 'Return back to current sheet before running again
Range("D15").Select
Loop 'syntax for continuation of while loop
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
Take out the second "i = " in your For line:
For i = 5 To 20
Related
Old Prompt
I've been trying to find a method of delimitating cells in Excel using the new line in the text with no luck. I need to delimitate a Cells string into multiple columns separated by the New Lines in the string so now I'm trying to find a way to do this with Visual Basics App. Does anyone have any useful advice or recommendations?
New Prompt
In the earlier portion of this assignment the goal was:
recognize Chr(10)
delimitate the text downward into a new column
keep the data from the same row
Previously I did not know there was a character that represented the new line. This is to say that I've found the solution to my problem and shared my results below.
OP ANSWER
It's me again. I know this might seem a bit messy and maybe not as efficient as it could be, but this is essentially what I was looking for. I hope this helps anyone in the future. Feel free to message me with any questions or concerns.
CODE
Sub Test()
Dim CountRows, FirstPortion, FullString, Row, Col
'Manually Set This Value
Row = 2
Col = 4
CountRows = 8
' '~~maybe i should count number of rows and increase count each time that a row is delimitated
' '~~~or just the same increase count when a new row is inserted
' '~~this would avoid the process of rechecking that a row has more to be delimitated
'------------------------------***{ROW TRAVERSAL}***---------------------------------
Do While Row < CountRows + 1
'---------------------------***{INITIALIZE}***-----------------------------------
FullString = Cells(Row, Col)
Debug.Print "Row"; Row; ":"; "FullString:"
Debug.Print FullString
'--------------------------***{REPLACEMENT}***----------------------------------
'If the row we point to contains a new line char then we want to replace newlines with "."
If InStr(FullString, Chr(10)) > 0 Then
Debug.Print "Row"; Row; " Info:"; " There is more than one line"
' 'replaces new line char with periods
FullString = Trim(Replace(FullString, Chr(10), "."))
Debug.Print "Row"; Row; ":"; "FullString:"
Debug.Print FullString
' 'counts number of periods in the current row
' '****{might not need}****
' Count = Len(Cells(Row, Col)) - Len(Replace(Cells(Row, 4), ".", ""))
End If
'---------------------------***{EXTRACTION}***----------------------------------
'------------------------------***{LOOP}***----------------------------------
'If the Row we point to contains a "." then that implies there is more names to be delimitated
'Knowing this we want to isolate the first portion of the String and isolate the remaining portion
'the remaining portion should be moved to the next inserted row
If InStr(FullString, ".") > 0 Then
Debug.Print "Row"; Row; " Info:"; " There is more than one period"
FirstPortion = Left(FullString, InStr(FullString, ".") - 1)
Debug.Print "Row"; Row; ":"; "FirstPortion:"
Debug.Print FirstPortion
FullString = Right(FullString, (Len(FullString) - Len(FirstPortion) - 1))
Debug.Print "Row"; Row; ":"; "FullString:"
Debug.Print FullString
'-----------------------***{INSERTION}***----------------------------------
'Now that the strings are seperated we must insert a new row to move the information to
Rows(Row + 1).Insert
CountRows = CountRows + 1
Debug.Print "Update the Row Count:"; CountRows
'-----------------------***{COPY DATA}***-----------------------------------
'Copy the relative data into the new row
Rows(Row).Copy Rows(Row + 1)
'-------------------***{DELIMITATE NAMES}***--------------------------------
'Set Current Row to first name to be delimitated
Cells(Row, Col) = FirstPortion
'Set Next Row to remaining names
Cells(Row + 1, Col) = FullString
End If
Row = Row + 1
Debug.Print "Row Pointing to:"; Row
Loop
Exit Sub
End Sub
DUMMY DATA
RESULT
I've got a workbook containing a Summary sheet and 200 numbered sheets that the user fills in one after the other.
The following macro checks about 125 cell values on every numbered sheet, and fills in the Summary, one line per numbered sheet.
If a numbered sheet hasnt been used yet, the macro fills in every column from column D to column DV with the minus sign "-" and goes on to check every numbered sheet one after the other till there's no more to check.
Is there a way to set it so that if an arbitrary number (let's say 10 lines) of the newly generated lines contain only the minus sign "-" from D to DV (Iw,4 to Iw, 126), then the macro would reach its end as it means all the remaining numbered sheets aren't used yet?
Sub SummaryMacro()
Dim Sh As Worksheet
Range("B2:L1000").ClearContents
Iw = 2 ' Index Write
For Each Sh In ActiveWorkbook.Sheets
If Sh.Name = "Summary" Then GoTo EndConsolidation
Cells(Iw, 1).Select
With Selection
.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & Sh.Name & "'" & "!" & "A1", TextToDisplay:="Go to"
End With
Cells(Iw, 2) = Sh.Name
If Sh.Range("D8") = "" Then
Cells(Iw, 3) = "-"
Else
Cells(Iw, 3) = Sh.Range("D8")
End If
'Here the rest of the process (Iw, 4 till Iw, 125)
'The process also includes a few variations:
'Something like 20 of those with various text
If Sh.CheckBoxes("Check Box 1").Value = 1 Then Cells(Iw, 40) = "Declared" Else Cells(Iw, 40) = "-"
'Something like 30 of those with various text
If Sh.Range("H33") = "Issued" Then
Cells(Iw, 42) = "-"
Else
Cells(Iw, 42) = Sh.Range("H33")
End If
'But all in all they are mostly like that
If Sh.Range("C134") = "" Then
Cells(Iw, 126) = "-"
Else
Cells(Iw, 126) = Sh.Range("C134")
End If
Iw = Iw + 1
EndConsolidation:
Next Sh
End Sub
Try adding this code to your For loop at the end:
If (WorksheetFunction.CountIf(Range("D" & Iw & ":DV" & Iw), "-") = 123) Then
Cntr = Cntr + 1 'Blank sheet found
Else
Cntr = 0 'Not blank - Restart counter
End If
If (Cntr = 10) Then Exit For
This counts the number of - in your row and if it equals 123 (D-DV) then it increments the counter otherwise it clears the counter. When Cntr reaches 10 it exits the loop.
HTH
Add this code before your For loop ends
Dim counter As Integer
Dim previousRowBlank As Boolean
counter = 0
previousRowBlank = True
'count if all the 123 cells contain - string
If (WorksheetFunction.CountIf(Sheets("Summary").Range("D" & Iw & ":DV" & Iw), "-") = 123) Then
If (counter = 0) Then
counter = counter + 1
previousRowBlank = True
Else
If (previousRowBlank = True) Then
counter = counter + 1
End If
End If
Else
previousRowBlank = False
counter = 0
End If
'assuming you want to exit when 10 consecutive rows are blank
If (counter = 10) Then
Exit Sub
End If
When I have something like this I Dim a Boolean variable (perhaps call it isPopulated) which only gets switched to true when one of the cells has a value to act on. Then for your case after 10 (or however many you choose) lines, insert an If isPopulated = False Then Exit For to skip the remaining sheets.
EDIT; another idea I just had for you - if all the cells you're checking are supposed to have numeric values then you could use the below;
If Not WorksheetFunction.Concat(Range("D8"), Range("C134"), etc) Like "*#*" Then
'Code here to skip this and remaining sheets.
Obviously you'd need to add the relevant ranges inside the concat() brackets. What that will do is join the contents of those cells together, then check the result for any numbers "*#*" (you could also check for any letters using "*?*"). That gives you a one-code-line answer to the basic question 'is this sheet populated or not'.
I'm sure it's a bad idea to terminate the macro prematurely, based on such an imprecise criterion as the number of "empty" sheets in series. If data starts again on the 11th, 15th or 30th sheet, then you will not process it, you will lose it.
Your macro is not very complex, it shouldn't take longer than a few seconds. For modern Excel, 25K cells are very few
Your code can be shortened a little, simplified. After all, you know all the addresses of the cells that you need to check on each sheet, you enter them in the macro code sequentially, right? Write them on one line separated by commas and put them in a constant.
After that, the whole code will become much shorter:
Sub SummaryMacro()
Const REQUIRED_CELLS_ADDRESS As String = "D8,...<all other source cells>...,B6"
Const SUM_SHEETNAME As String = "Summary"
Dim ws As Worksheet
Dim wsSum As Worksheet
Dim rCell As Range
Dim oTargetCell As Range
Dim oSumCell As Range
Dim aAddress As Variant
Dim i As Integer
aAddress = Split(REQUIRED_CELLS_ADDRESS, ",")
Set wsSum = ActiveWorkbook.Worksheets(SUM_SHEETNAME)
wsSum.UsedRange.Offset(1, 0).ClearContents
Set oTargetCell = wsSum.Range("A1")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> SUM_SHEETNAME Then
Set oTargetCell = oTargetCell.Offset(1, 0)
wsSum.Hyperlinks.Add Anchor:=oTargetCell, Address:="", SubAddress:="'" & ws.Name & "'" & "!" & "A1", TextToDisplay:="Go to"
oTargetCell.Resize(1, 123).Value = "-"
Set oSumCell = oTargetCell.Offset(0, 1)
oSumCell.Value = ws.Name
For i = LBound(aAddress) To UBound(aAddress)
Set rCell = ws.Range(aAddress(i))
Set oSumCell = oSumCell.Offset(0, 1)
If Not IsEmpty(rCell) Then oSumCell.Value2 = rCell.Value2
Next i
End If
Next ws
End Sub
Update Everyone knows that working with an array in RAM is much faster than working with sheet cells. Therefore, the outer loop - iterating over the sheets of the book - remains the same, but we change the code inside the loop in this way:
Sub SummaryMacro()
Const SUM_SHEETNAME As String = "Summary"
Dim ws As Worksheet
Dim wsSum As Worksheet
Dim oTargetCell As Range
Dim aResData As Variant
aAddress = Split(REQUIRED_CELLS_ADDRESS, ",")
Set wsSum = ActiveWorkbook.Worksheets(SUM_SHEETNAME)
wsSum.UsedRange.Offset(1, 0).ClearContents
Set oTargetCell = wsSum.Range("A1")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> SUM_SHEETNAME Then
Set oTargetCell = oTargetCell.Offset(1, 0)
wsSum.Hyperlinks.Add Anchor:=oTargetCell, Address:="", SubAddress:="'" & ws.Name & "'" & "!" & "A1", TextToDisplay:="Go to " & ws.Name
aResData = validateData(ws.Range("A1:L140").Value2) ' Or "D8:C134" or any other
oTargetCell.Offset(0, 1).Resize(1, UBound(aResData) + 1).Value = aResData
End If
Next ws
End Sub
The main trick is hidden in this line aResData = validateData(ws.Range("A1:L140").Value2)
We call our function and pass it as a parameter an array of cell values from the entire next sheet. Further work on analysis and processing will be carried out with the elements of this array. However, this is not the whole trick.
The validateData() function is very simple and looks like this:
Function validateData(aD As Variant) As Variant
validateData = validateValues(aD(1, 5), aD(2, 8), aD(3, 1), aD(2, 11), _
........ , _
aD(111, 3), aD(112, 8), aD(123, 9), aD(126, 10))
End Function
In other words, we select from the entire large array of aD (the name is deliberately made short, because in this function it will have to be repeated 123 times) only those values that need to be analyzed and we pass on to the next function. Despite the seeming simplicity, this is the most time-consuming part - you need to select from the sheet all cells "D8", "C134", etc. and write down their coordinates (row, column) as numbers aD(4,8), aD(3,134), etc.
Perhaps can help in this the mode R1C1 of displaying the sheet. Or some kind of helper function that will be used when preparing the code (not when executing - we agreed that we will no longer access cells for get values or for .Row and .Column properties!)
What will the validateData() function get? A long one-dimensional array aData(0 To 122) of cell values in the listed order. That is, as many values as there are cells to be filled in the Summary row for this sheet.
The last trick is the process of processing values. It would seem that we have gained nothing from all these transformations. But you claim that there are three groups of checks - for an empty value, for a boolean value (checkbox) and for text lines. This is how it is handled:
Function validateValues(ParamArray aData() As Variant) As Variant
Dim i As Variant
Dim aResult As Variant
ReDim aResult(LBound(aData) To UBound(aData))
For i = LBound(aData) To UBound(aData)
Select Case i
Case 1, 5, 7, 9 ' Checking cells empty / value
aResult(i) = IIf(aData(i) = "", "-", aData(i))
Case 4, 6, 10 ' Checking cells boolean True / "not True" (False or blank)
aResult(i) = IIf(aData(i), "Declared", "-")
Case 0, 3, 8 ' Checking cells string "Issued" / other
aResult(i) = IIf(aData(i) = "Issued", "-", aData(i))
Case 2, 91, 118 ' Checking cells string "Pending" / other
aResult(i) = IIf(aData(i) = "Issued", "-", aData(i))
Case Else ' In a real macro, this line is not needed, it will never be executed because all the cells of the array are already listed above, this is useful only for debugging while all conditions will be written
aResult(i) = "-"
Debug.Print "Cell #" & i & " not processed yet"
End Select
Next i
validateValues = aResult
End Function
And now - again, in just one call! - we write a whole row of results:
oTargetCell.Offset(0, 1).Resize(1, UBound(aResData) + 1).Value = aResData
I am sure that these tricks will reduce the time it takes to form the summary sheet many times over. Please try this and let me know if it gets better?
The excel file for dates of duties taken by persons are as shown in figure. Marked duties as X
How can I get the date of duties taken by a particular person using filtering?
Is there any method to get each person's name together with their duty date in a separate sheet?
I think what you're trying to do is:
Unpivot:
Select the data and on the Insert menu choose Table
On the Data menu click From Table/Range
The query window will open. Choose the columns you need to extract. With your data the columns to highlight are "Type" and "Number of Cases"
On the Tranform menu choose Unpivot Columns
If the data looks right now, close the Query Editor (accepting changes).
Another example:
If your goal is to get from this:
...to this (or that):
...then what you want to do is called an Unpivot.
How to Unpivot "crosstab-style" data:
You can find the steps written out on a question I answered here, and there's a more detailed explanation and steps over here.
Approach via array filtering
You need filter results row wise (e.g. Tessy Paul- 26 April 18, 27 April 18, 30 April 18, 2-May 18), but IMO you won't get them via advanced filter method. Instead I demonstrate an alternative approach using arrays to get the source data (looping through a range via VBA is slow) and to extract the rearranged (=recoded) data via Application.Filter matching items marked by "x" as duty.
Essential steps
First you write all your data to a variant 2-dimensioned datafield array simply by assigning a predefined range reference - see section [2]:
Dim v As Variant ' or simply: Dim v
Dim rng As Range
'set rng = ...
v = rng.Value2 ' or simply: v = rng
Furthermore it's possible to filter an array via Application.Filter with some restrictions:
a) you'll need some further information beyond the isolated cell data and
b) you'll need a 1-dim array.
ad a) In order to identify name and duty date when filtering, just add these information together with a delimiter (e.g. "#", see section [3]).
This allows you to split the filtered data later by looping through each array item - see sections [4] and [5].
ad b) To get a 1-dim array out of a 2-dim array you can extract a row or a column via Application.Index function.
In the example below I assign results to another array called vi.
For example: if you want to extract a row as shown in section 4.1, the second parameter identifies the row number starting from 1, the third argument column number simply obtains 0 :
Then you can apply the Filter function with this newly dimensioned source array and a match string "x#" to get all data defined as Duty by the x character and the chosen delimiter #.
vi = VBA.filter(Application.Index(v, i, 0), "x#", True, False)
Notes:
The match string consists of both characters ("x#"), as "x" alone could be part of a name (e.g. Alexander), too.
As an addition to row wise filtering:
To extract a column see section 5.1, as this needs an additional adjusting via Application.Transpose.
Each extracted row or column array will be written back to a target sheet and shown via Join function in Debug.Print in your immediate window in the Visual Basic Editor (VBE)
Code Example
Option Explicit
Sub DutiesPerName()
' Site: https://stackoverflow.com/questions/50083149/how-can-i-use-advance-filtering-row-wise
' [0] Declare variables
Dim a()
Dim ws As Worksheet, ws2 As Worksheet
Dim rng As Range, i As Long, j As Long, r As Long, c As Long
Dim v, vi, temp
' [1] define sheetname and data range
' 1.0 set worksheet object to memory
Set ws = ThisWorkbook.Worksheets("MyDataSheet") ' << change to your data sheet name
Set ws2 = ThisWorkbook.Worksheets("MyDutySheet") ' << change to your target sheet name
' 1.1 get rows and columns
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
c = ws.Range("A1").End(xlToRight).Column
' 1.2 Alternative code line: Set rng = ws.UsedRange
Set rng = ws.Range(ws.Range(ws.Cells(1, 1), ws.Cells(r, c)).Address)
' [2] create a variant 1-based 2-dim datafield array
v = rng.Value2
' [3] CODE duty items by appending "#" plus date and name info
For i = 2 To UBound(v) ' start loop from 2nd row
v(i, 1) = "x#" & v(i, 1) ' mark name captions to get them filtered, too
For j = 3 To UBound(v, 2) ' start inner loop from 3rd column
If v(i, j) = "x" Then ' code found duty items
v(i, j) = v(i, j) & "#" & Format(v(1, j), "dd-mmm-yy") & "#" & v(i, 1) & "#" & j
'Debug.Print "v(" & i & "," & j & ")=""" & v(i, j) & """"
End If
Next j
Next i
' mark date captions with "x#" to get them filterd, too
For j = 3 To UBound(v, 2)
v(1, j) = "x###" & Format(Val(v(1, j)), "dd-mmm-yy")
Next j
' -----------------------
' [4] Duty Dates per Name:
' -----------------------
ws2.Cells.Clear: ws2.Range("A1") = "Name": ws2.Range("B1") = "Duty Dates ..."
For i = 2 To UBound(v, 1) ' start loop from 2nd row
' 4.1 filter redimensioned 1-dim ROW array via "x#"
vi = VBA.filter(Application.Index(v, i, 0), "x#", True, False)
For j = LBound(vi) To UBound(vi)
vi(j) = Split(vi(j), "#")(1) ' extracts date from e.g. "x#15-Jan-19#x#Paul#2"
Next j
' write dates per name into target worksheet ws2
ws2.Range("A1").Offset(i - 1, 0).Resize(1, UBound(vi) + 1) = vi
Debug.Print "Row# " & i & " (" & _
ws2.Range("A1").Offset(i - 1, 0).Resize(1, UBound(vi) + 1).Address & ") 1 Name + " & UBound(vi) & " Dates: " & _
Join(vi, ", ")
Next i
Debug.Print
' -----------------------
' [5] Names per Duty Date:
' -----------------------
ws2.Range("A1").Offset(r + 2, 0) = "Duty Date": ws2.Range("A1").Offset(r + 2, 1) = "Names ..."
For i = 3 To UBound(v, 2) ' start loop from 3rd column
' 5.1 filter redimensioned 1-dim COLUMN array via "x#"
vi = VBA.filter(Application.Transpose(Application.Index(v, 0, i)), "x#", True, False)
For j = LBound(vi) To UBound(vi)
temp = Split(vi(j), "#")
vi(j) = temp(3) ' extracts Name from e.g. "x#15-Jan-19#x#Albert#3"
Next j
' write each names per date into target worksheet ws2
If UBound(vi) > -1 Then
ws2.Range("A1").Offset(r + i, 0).Resize(1, UBound(vi) + 1) = vi
Debug.Print "Col# " & i & " (" & _
ws2.Range("A1").Offset(r + i, 0).Resize(1, UBound(vi) + 1).Address & ") 1 Date + " & UBound(vi) & " Names: " & _
Join(vi, ", ")
End If
Next i
End Sub
I am attempting to copy results from another sheet based on the cell values on the active worksheet. i.e loop through every element in array "GWworkStations()" and find a match in column B of "Col List" sheet, and then copy the corresponding values in "C:E" to an array "MatchedEntries" so I can copy them back to the active sheet.
The code is returning empty for "matchedRow", instead of reporting the row number. I am not getting an error.
dim MatchedEntries() as string
dim GWworkStations() as variant
number_of_rows = ActiveSheet.UsedRange.Rows.Count
With ActiveWorkbook.Worksheets("New Sheet")
GWworkStations() = range("B2:B" & number_of_rows)
End With
ReDim MatchedEntries(1 To r) 'Size the array to hold the results.
'for every cell that is not empty in GWworkStations(), search through column B of 'Col List ' sheet.
For i = 1 To number_of_rows
'matchedRow = Empty
On Error Resume Next 'Keep running if Excel MATCH function below doesn't find a match.
If Not IsEmpty(Cells(i, 1)) Then
matchedRow = Application.WorksheetFunction.Match(GWworkStations(i, 1), range("Col List!B:B"), 0)
If matchedRow = Empty Then Debug.Print "Empty " & matchedRow
If IsEmpty(matchedRow) Then 'No match.
MatchedEntries(i, 1) = "" 'GWworkStations(i, 1)
Else
'If GWworkStations(i, 1) = GWworkStations(i - 1) Then
If IsNumeric(matchedRow) Then 'Match was found.
MatchedEntries(i, 1) = Application.WorksheetFunction.Index(range("List!C:E"), matchedRow, 1)
Else 'MATCH function returned a non-numeric result.
MatchedEntries(i, 1) = ""
End If 'IsNumeric(MatchedRow)
End If 'IsEmpty(MatchedRow)
Else
End If
Next i
range("E2:G" & number_of_rows) = MatchedEntries() 'Write the tag name results out to range E:G.
Excel doesn't like the space in the sheet name. You can fix this by using single quotes: Range("'Col List'!B:B"), or by replacing Range("Col List!B:B")with Sheets("Col List").Columns(2).
You could also use the Range.Find method (which I would prefer):
matchedRow = Sheets("Sheet 3").Columns(2).Find(str).Row
I am getting an error I can't figure out:
After I run the macro below, two certain string values are pasted into the same two cells in ALL sheets, although I am sure that the sheets are not grouped or do not contain individual code of their own. Specifically, the items "B12" and "B25" are pasted on all pages at the same cells (A29 and A30) (See code). "B12" and "B25" have nothing to do with a cell location but are just identifiers unique to my application. They are values which are copied+pasted from one sheet into another. If it is a copy+paste error in the code, then I would expect all the items to have the same error because the "algorithm" subroutine is called for every sheet.
Sometimes, this also occurs without execution of the macro. And when I try to edit my workbook back to how it was before fields were pasted over (by clicking each cell and typing what used to be there), it still makes those changes to all sheets, even though I am sure they are not grouped or running code.
' Title: DSR AutoFill Macro
Sub autofill_DSR()
' Variable Declarations:
Dim x_count As Long
Dim n As Long
Dim item_a As String
Dim item_b As String
'Dim test_string As String
' Variable Initializations:
x_count = 0
Process_Control_NumRows = 15
Electrical_NumRows = 8
Environmental1_NumRows = 17
Env2_Regulatory_NumRows = 14
FIRE_NumRows = 15
Human_NumRows = 16
Industrial_Hygiene_NumRows = 16
Maintenance_Reliability_NumRows = 10
Pressure_Vacuum_NumRows = 16
Rotating_n_Mechanical_NumRows = 11
Facility_Siting_n_Security_NumRows = 10
Process_Safety_Documentation_NumRows = 3
Temperature_Reaction_Flow_NumRows = 18
Valve_Piping_NumRows = 22
Quality_NumRows = 10
Product_Stewardship_NumRows = 20
fourB_Items_NumRows = 28
'test_string = "NN"
' Main Data Transfer Code:
Sheets(Array("SUMMARY P.1", "SUMMARY P.2", "Process Control", _
"Electrical", "Environmental1", "Env.2 - Regulatory", "FIRE", _
"Human", "Industrial Hygiene", "Maintenance_Reliability", _
"Pressure_Vacuum", "Rotating & Mechanical", _
"Facility Siting & Security", "Process Safety Documentation", _
"Temperature-Reaction-Flow", "Valve-Piping", "Quality", _
"Product Stewardship", "4B ITEMS")).Select 'Create Array of all Sheets
'Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select ' For testing
' Process Control Sheet:
For n = 0 To (Process_Control_NumRows - 1) 'Cycle 16 times for each
'item row in process controls tab
Sheets("Process Control").Activate 'Choose specific sheet
Range("D15").Select 'Choose starting cell of "Yes" column
Call Module2.algorithm(n, x_count) 'Call on subroutine (see algorithm code)
Next n 'increment index to account for offset
' Electrical Sheet:
For n = 0 To (Electrical_NumRows - 1)
Sheets("Electrical").Activate
Range("D15").Select
Call Module2.algorithm(n, x_count)
If (x_count > 21) Then 'Abort autofill if too many items to hold
Sheets("SUMMARY P.1").Activate 'on both summary pages put together (21 count)
GoTo TooMany_Xs
End If
Next n
This continues for all the sheets...
' 4B ITEMS Sheet:
For n = 0 To (fourB_Items_NumRows - 1)
Sheets("4B ITEMS").Activate
Range("D16").Select ' NOTE: Starting cell is "D16"
Call Module2.algorithm(n, x_count)
If (x_count > 21) Then
Sheets("SUMMARY P.1").Activate
GoTo TooMany_Xs
End If
Next n
If (x_count > 5) Then 'Bring user back to last logged sheet
Sheets("SUMMARY P.2").Activate
Else
Sheets("SUMMARY P.1").Activate
End If
TooMany_Xs:
If Err.Number <> 0 Then
Msg = "you put more than 21 Items on the Summary Pages." & Chr(13) & _
"Consider editing your DSR or taking some other action."
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
End Sub
And then this following macro is located in Module2:
Sub algorithm(n As Long, x_count As Long)
'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
ActiveCell.Offset((x_count - 1), 0).Value = (item_a & item_b)
End If
End If
End Sub
By selecting all the sheets in your array, you are grouping them, and anything you write to a cell in any sheet will be written to all sheets.
This is the culprit:
Sheets(Array("SUMMARY P.1", "SUMMARY P.2", "Process Control", _
"Electrical", "Environmental1", "Env.2 - Regulatory", "FIRE", _
"Human", "Industrial Hygiene", "Maintenance_Reliability", _
"Pressure_Vacuum", "Rotating & Mechanical", _
"Facility Siting & Security", "Process Safety Documentation", _
"Temperature-Reaction-Flow", "Valve-Piping", "Quality", _
"Product Stewardship", "4B ITEMS")).Select
The fact that your issue occurs even if the code you posted hasn't been run makes me think there is something else going on after you've selected all the sheets.
Note that selecting and activating are a really bad idea. Declare variables for the objects you want to work with and interact with them that way instead of selecting them.
Here is a quick example of how you can loop through all the sheets in a workbook and modify them without selecting or activating. You can modify your code to use this pattern:
Sub LoopThroughAllSheets()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
For Each ws In wb.Sheets
ws.Range("D15").Value = ws.Name
Next ws
End Sub
Please read the following to get you started on writing cleaner, more efficient VBA code:
Beginning VBA: Select and Activate
Excel macro - Avoid using Select
Sheets(Array("SUMMARY P.1", "SUMMARY P.2", "Process Control", _
"Electrical", "Environmental1", "Env.2 - Regulatory", "FIRE", _
...
"Product Stewardship", "4B ITEMS")).Select
is grouping all these worksheets. At some point you need to Ungroup them by selecting a single worksheet:
Worksheets("Whatever").Select
You should also examine your code to check whether grouping the worksheets is actually necessary.