Related
I have written VBA code to find the duplicate value and bulk upload the data to another sheet.
If any duplicate in A, B, C Columns I need a message box, and to cancel the bulk upload.
Example of my columns - marked in red are duplicate values:
Option Explicit
Private Sub CommandButton1_Click()
Dim rng As Range
Dim l As Long, r As Long, msg As String
Dim lRow, lRow1 As Long
Application.ScreenUpdating = False
l = Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To l
If Evaluate("COUNTIFS(A:A,A" & r & ",B:B,B" & r & ",C:C,C" & r & ")") > 1 Then msg = msg & vbCr & r
Next
MsgBox msg, vbInformation, "DUPLICATE ROWS"
Exit Sub
lRow = [Sheet2].Cells(Rows.Count, 1).End(xlUp).Row
lRow1 = [Sheet3].Cells(Rows.Count, 1).End(xlUp).Row + 1
[Sheet2].Range("A4:N" & lRow).Copy
[Sheet3].Range("A" & lRow1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Sheet3.Select
[Sheet3].Range("A1").Select
Sheet2.Select
[Sheet2].Range("A1").Select
End Sub
Something like this should work fine:
For r = 2 To l
If Evaluate("COUNTIFS(A:A,A" & r & ",B:B,B" & r & ",C:C,C" & r & ")") > 1 Then
msg = msg & vbCr & r
End If
Next r
If Len(msg) > 0 Then
MsgBox msg, vbInformation, "DUPLICATE ROWS"
Exit Sub
End If
Extended Formula evaluation without loops
Extending on Tim's row-wise formula evaluation a couple of tips:
Fully qualify your range references; without explicit indications VBA assumes the active sheet, which needn't be the one you have in mind.
Execute a worksheet-related evaluation for the same reason; doing so it suffices here to indicate e.g. "A:A" instead of inserting a sheet prefix "Sheet1!..." each time.
Example procedure
Option Explicit ' force declaration of variables on top of code module
Sub IdentifyDuplicateRows()
With Sheet1 ' using the project's Sheet Code(Name)
'1. get last row & build formula
Dim l As Long
l = .Range("A" & Rows.Count).End(xlUp).Row
Dim myFormula As String
myFormula = "=IF(COUNTIFS(A:A,A2:A" & l & ",B:B,B2:B" & l & ",C:C,C2:C" & l & ")>1,""Duplicate Row "" & Row(A2:A" & l & "),"""")"
'2. get results & write to target
Dim results As Variant
results = .Evaluate(myFormula) ' note the "."-prefix!
With .Range("D2").Resize(UBound(results))
.Value = results 'write results to target
End With
'3. optional additional MsgBox info (see below)
' ...
End With
End Sub
Note to optional message box info
If you prefer a further info via message box you could insert the following block before End With:
'3. optional display in message box
'filter only elements containing "Dup" (change to flat & eventually 0-based array)
results = Application.Transpose(results)
results = Filter(results, "Dup") ' omitted default argument Include:=True
'count duplicate rows and display message
Dim cnt As Long
cnt = UBound(results) + 1
MsgBox Join(results, vbNewLine), vbInformation, cnt & " Duplicate Rows"
There is a list of ID's with their chosen subjects in their respective row. I am trying to write code that will read through the subjects, and ensure that any two out of a selected four of the subjects are chosen (out of 15 subjects), and if it isn't be reported back as an error. The subjects needed are either SBC130, SBC150, SBC210 or SBC220, and any combination of the 2 are good out of a range of 15 possible subjects.
This is the code I have so far
Dim programme, module, ID As String
Dim rng As Range
Dim a, b, c, d As Variant
lastidno = Range("A2", Range("A2").End(xlDown)).Count
For i = 2 To lastidno
Sheets("Part B + C Modules").Activate
Set rng = Range("C" & i, Range("C" & i).End(xlToRight))
For j = 1 To 4
Set a = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC130", LookIn:=xlValues, lookat:=xlWhole)
Set b = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC150", LookIn:=xlValues, lookat:=xlWhole)
Set c = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC210", LookIn:=xlValues, lookat:=xlWhole)
Set d = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC220", LookIn:=xlValues, lookat:=xlWhole)
If a Is Nothing And b Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 1"
ElseIf a Is Nothing And c Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 2"
ElseIf a Is Nothing And d Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 3"
ElseIf b Is Nothing And c Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 4"
ElseIf b Is Nothing And d Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 5"
ElseIf c Is Nothing And d Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 6"
End If
Next
Next
Please share your thoughts on what the relevant steps are to complete this! Thanks in advance!
Here's a generic function that will check a range against a list of values and determine if the quantity of unique values from the provided list is greater than or equal to a desired threshold:
Function CheckUnqValueQty(ByVal arg_rData As Range, ByVal arg_lThreshold As Long, ByVal arg_aValues As Variant) As Boolean
'This gets the number of unique values listed in arg_aValues found in the arg_rData range
Dim lEvalResult As Long
On Error Resume Next 'Suppress errors if any of the arguments were supplied incorrectly or if any of the data cells contain error values
lEvalResult = Evaluate("SUMPRODUCT(--(COUNTIF(" & arg_rData.Address(External:=True) & ",{""" & Join(arg_aValues, """,""") & """})>0))")
On Error GoTo 0 'Remove the "On Error Resume Next" condition (no longer suppress errors); if there was an error, lEvalResult will be 0
'If the eval result is >= the threshold then return True, else False
CheckUnqValueQty = (lEvalResult >= arg_lThreshold)
End Function
And then you'd call that function from within your loop, like so:
Sub tgr()
'Define the list of subjects
Dim aSubjects() As Variant
aSubjects = Array("SBC130", "SBC150", "SBC210", "SBC220")
'Define the valid threshold
Dim lValidQty As Long
lValidQty = 2
'Make sure we're working with the correct worksheet
With ActiveWorkbook.Worksheets("Part B + C Modules")
'Initiate the loop starting at row 2 and going to last used row
Dim i As Long
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
'Define the range to check
Dim rCheck As Range
Set rCheck = .Range(.Cells(i, "C"), .Cells(i, .Columns.Count).End(xlToLeft))
'Call the function to check if the appropriate number of different subjects have been selected
If CheckUnqValueQty(rCheck, lValidQty, aSubjects) = True Then
'valid result, 2 or more different required subjects selected
'do something for a valid result here
Else
'invalid result, 0 or 1 required subjects selected
ActiveWorkbook.Worksheets("Available sub").Cells(i, "F").Value = "Incorrect"
End If
Next i
End With
End Sub
If a formula works:
=IF(AND(B1<>B2,COUNTIF(C1:C4,B1)+COUNTIF(C1:C4,B2)=2),"OK","Incorrect")
For some VBA, maybe something like this:
Dim tempstring As String
With Sheets("unknown")
tempstring = .Range("C1").Value & "|" & .Range("C2").Value & "|" & .Range("C3").Value & "|" & .Range("C4").Value
If InStr(tempstring, .Range("B1").Value) > 0 And InStr(tempstring, .Range("B2").Value) > 0 Then
Sheets("Available sub").Range("F1") = "OK"
Else
Sheets("Available sub").Range("F1") = "Incorrect"
End If
End With
Note that you don't qualify the sheets for all you ranges so I used a sheet called "unknown", adjust the code to match you workbook
If your Student ID numbers are in column B (change column as needed) you could loop through each Student ID, and Count the number of cells with constants in the range for each row. Your notification can be a message box or color the Student ID interior color red, with this basic macro.
For Each cel In ActiveSheet.Range("B2", Range("B" & Rows.Count).End(xlUp))
If cel.Resize(, 4).Offset(, 1).SpecialCells(xlCellTypeConstants).Count < 2 Then
MsgBox "Student " & cel.Text & "did not select two subjects"
'Or
cel.Interior.Color = RGB(256, 0, 0)
End If
Next cel
so i have Sheet1 that is use to contain the list of my inventory data. what i want to do is in another sheet(Sheet2). i can search my Sheet1 data and display the data there ( for example when i type cheetos, only the cheetos item got display ). Help me guys, using VBA is okay or other method is also fine.
If your results don't have to be on a different sheet, you could just convert your data to a Table. Select Cells A1:D8 and click on Insert -> Table. Make sure "My table has headers" is clicked and voila!
Once formatted as a table, you can filter Product ID however you need.
If you do need to show these results in another sheet, VBA would be my go-to solution. Maybe something like this:
Public Sub FilterResults()
Dim findText As String
Dim lastRow As Long
Dim foundRow As Long
Dim i As Long
'If there's nothing to search for, then just stop the sub
findText = LCase(Worksheets("Sheet2").Range("D4"))
If findText = "" Then Exit Sub
'Clear any old search results
lastRow = Worksheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Row
If lastRow > 5 Then
For i = 6 To lastRow
Worksheets("Sheet2").Range("C" & i).ClearContents
Worksheets("Sheet2").Range("D" & i).ClearContents
Worksheets("Sheet2").Range("E" & i).ClearContents
Worksheets("Sheet2").Range("F" & i).ClearContents
Next i
End If
'Start looking for new results
lastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
foundRow = 6
For i = 2 To lastRow
If InStr(1, LCase(Worksheets("Sheet1").Range("B" & i)), findText) <> 0 Then
Worksheets("Sheet2").Range("C" & foundRow) = Worksheets("Sheet1").Range("A" & i)
Worksheets("Sheet2").Range("D" & foundRow) = Worksheets("Sheet1").Range("B" & i)
Worksheets("Sheet2").Range("E" & foundRow) = Worksheets("Sheet1").Range("C" & i)
Worksheets("Sheet2").Range("F" & foundRow) = Worksheets("Sheet1").Range("D" & i)
foundRow = foundRow + 1
End If
Next i
'If no results were found, then open a pop-up that notifies the user
If foundRow = 6 Then MsgBox "No Results Found", vbCritical + vbOKOnly
End Sub
I would recommend avoiding VBA for this process as it can be done easily with excel's functions. If you would like to do it via VBA one could just loop through the list of products and find a key word, adding it to an array if the "Cheetos" is contained in the specific cell value using a wildcard like so:
This could be modified to run upon the change of the D4 cell if needed, and of course some modifications could be done to ensure that formatting etc can be done to your liking.
Sub test()
Dim wb As Workbook
Dim rng As Range, cell As Range
Dim s_key As String, s_find() As String
Dim i As Long
Set wb = Application.ThisWorkbook
Set rng = wb.Sheets("Sheet1").Range("B2:B8")
s_key = wb.Sheets("Sheet2").Range("D4").Value
wb.sheets("Sheet2").Range("C6:F9999").clearcontents
i = 0
For Each cell In rng
If cell.Value Like "*" & s_key & "*" Then
ReDim Preserve s_find(3, i)
s_find(0, i) = cell.Offset(0, -1).Value
s_find(1, i) = cell.Value
s_find(2, i) = cell.Offset(0, 1).Value
s_find(3, i) = cell.Offset(0, 2).Value
i = i + 1
End If
Next cell
wb.Sheets("Sheet2").Range("C6:F" & 5 + i).Value = Application.WorksheetFunction.Transpose(s_find)
End Sub
I have a function in a larger macro that helps reformat and clean up some data from a specific measurement file so that it can be used by the rest of the macro. I recently needed to update some of the data clean-up & reformatting that the function does based on guidance from the department that uses the macro. Those changes work fine, but now the .SaveAs is failing on Error 1004 "SaveAs method of object '_Workbook' failed".
I compared the old & new versions in a text comparison program (UltraCompare) and the changes definitely shouldn't impact the SaveAs. If I stop the macro at the point just before SaveAs and manually save that works successfully, so nothing in the file itself is blocking the save, nor is it a permissions change I didn't know about (which is extra not likely since the test folder is a child of my Desktop).
To go through some of the answers I've seen to other questions on this error
I don't use ActiveWorkbook to save, I create the workbook when setting a workbook variable
I don't use a date in the save as file name
There are no hyperlinks in the workbook
Excel doesn't throw a prompt, and alerts are left on prior to the SaveAs line
As mentioned above, the save is to a folder off my Desktop, so network drive mapping involved
Some additional things I've tried:
During debug, creating a new variable immediately prior to the .SaveAs line & populating it with a new file name in the same folder, and using that in the .SaveAs in place of the replace
Again with a new variable prior to .SaveAs that specifies a different folder
Specifying FileFormat:=51
All that said, here's the code, if anyone has ideas I'm game:
Function MergeCDC(sw As StatWin, fpath As String, BadDateRef As Range, Optional FromComb As Boolean = False) As Boolean
'StatWin is a custom form with a text box for printing status text to the user & a progress bar. fpath is the full file path of the file to be used as a string (folder path & file name including file extension)
'BadDateRef is a cell in the workbook that holds this function that holds the date 1/1/1900 which is used by the file being processed to indicate no date (i.e. the field should be null, but the DBAs
'decided to be weird so we have to deal with it)
'FromComb is a way to know if this function was called by a specific other function, so that run time tracking can be handled correctly
'Check if we're blocked on CDC (this prevents the function from trying to run again if it's called a second (or greater) time after failing)
If sw.CDCBlock Then
MergeCDC = False
Exit Function
End If 'else continue
Dim src As Workbook
Set src = Workbooks.Open(fpath) 'No need to check if the CDC workbook is present as that was done prior to this function being invoked
Dim ry As Worksheet
Dim ytd As Worksheet
Dim m As Workbook
Set m = Workbooks.Add
Dim ms As Worksheet
Set ms = m.Worksheets(1)
Dim ret As Boolean
ret = False
Dim c As Long
Dim r As Long
Dim ryc As Long
Dim temp() As Long
Dim msc As Long
Dim z As Integer
Dim yfnd As Boolean
Dim rfnd As Boolean
'Update the RunStat sheet such that we track CDC data merge as it's own item
If FromComb Then
sw.RStat.Range("A" & sw.StatRow + 2).Value = sw.RStat.Range("A" & sw.StatRow + 1).Value
sw.RStat.Range("B" & sw.StatRow + 2).Value = sw.RStat.Range("B" & sw.StatRow + 1).Value 'Bump start time for combined list being created
sw.RStat.Range("A" & sw.StatRow + 1).Value = sw.RStat.Range("A" & sw.StatRow).Value 'bump start for creation of combined source file
sw.RStat.Range("B" & sw.StatRow + 1).Value = sw.RStat.Range("B" & sw.StatRow).Value
Else
sw.RStat.Range("A" & sw.StatRow + 1).Value = sw.RStat.Range("A" & sw.StatRow).Value 'bump start for creation of CDC list
sw.RStat.Range("B" & sw.StatRow + 1).Value = sw.RStat.Range("B" & sw.StatRow).Value
End If
sw.RStat.Range("A" & sw.StatRow).Value = "CDC Merge"
sw.RStat.Range("B" & sw.StatRow).Value = Now()
'Determine which sheet is which
z = 1
yfnd = True
rfnd = True
Do While z <= src.Worksheets.Count And (yfnd Or rfnd)
If InStr(1, UCase(src.Worksheets(z).Name), "YTD") > 0 Then
yfnd = False
Set ytd = src.Worksheets(z)
ElseIf InStr(1, UCase(src.Worksheets(z).Name), "RY") > 0 Then
rfnd = False
Set ry = src.Worksheets(z)
End If
z = z + 1
Loop
'Check we found both sheets
If rfnd Or yfnd Then
Call Err("Unable to locate the RY and/or YTD worksheets in the Unedited CDC file. Please update the file such that the YTD worksheet includes 'YTD' in its name, and the RY" _
& " worksheet includes 'RY' in its name. This error prevents any list utilizing CDC data from being completed.", sw)
MergeCDC = False
sw.CDCBlock = True
Exit Function
End If 'else continue as normal
'Prep the two worksheets
temp = CDCPrep(ry, True, sw)
ryc = temp(0)
r = temp(1) 'CDCPrep returns the first BLANK row so we will use r as the row to paste to when pasting YTD data
'Prep of RY successful?
If temp(0) <> -1 Then
temp = CDCPrep(ytd, False, sw)
Else
'Close the new workbook without saving
m.Close SaveChanges:=False
End If
'Continue?
If temp(0) <> -1 Then
'Copy the entirety of Rolling Year data
ry.Range("A1:" & ColNumToStr(ryc) & r - 1).Copy
ms.Range("A1").PasteSpecial xlPasteAll
'Start merging in the YTD data. Since we can't assume the columns are in the same order we'll start iterating through the RY columns and copying one column at a time from YTD
c = 0
Do While ms.Range("A1").Offset(0, c).Value <> ""
'Find the matching column in YTD
msc = 0
Dim fnd As Boolean
fnd = False
Do While ytd.Range("A1").Offset(0, msc).Value <> "" And fnd = False
If ytd.Range("A1").Offset(0, msc).Value = ms.Range("A1").Offset(0, c).Value Then
'Found the column. Copy it's data
fnd = True
ytd.Range(ColNumToStr(msc + 1) & "2:" & ColNumToStr(msc + 1) & temp(1)).Copy
Else
msc = msc + 1
End If
Loop
'Did we find a match?
If fnd Then
'Paste the data
ms.Range("A" & r).Offset(0, c).PasteSpecial xlPasteAll
Else
Call Err("Unable to locate the " & ms.Range("A1").Offset(0, c).Value & " column in the Yr To Date data. The list will be generated, but will be missing these values for items found only" _
& " in the Yr To Date data.", sw)
End If
c = c + 1
Loop
'Get the last row of data so we can sort the merged data
r = r + temp(1)
'Check that is the last row
Do While ms.Range("A" & r).Value <> "" And r < 600000 'ridiculously high value, but serves as a fail-safe to keep from hitting end of sheet and not having found data end
r = r + 1
Loop
'Sort the data and remove duplicates according to the current month (Jan - Jun: RY rows preferred to YTD; Jul - Dec: YTD preferred)
If Month(sw.CurDate) < 7 Then
'RY preferred
ms.Sort.SortFields.Clear
ms.Sort.SortFields.Add Key:=Range _
("A2:A" & r), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ms.Sort.SortFields.Add Key:=Range _
("B2:B" & r), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ms.Sort
.SetRange Range("A1:" & ColNumToStr(c + 1) & r + temp(1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Else
'YTD preferred
ms.Sort.SortFields.Clear
ms.Sort.SortFields.Add Key:=Range _
("A2:A" & r), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ms.Sort.SortFields.Add Key:=Range _
("B2:B" & r), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ms.Sort
.SetRange Range("A1:" & ColNumToStr(c + 1) & r + temp(1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
ms.Range("A1:" & ColNumToStr(c + 1) & r + temp(1)).RemoveDuplicates Columns:=1, Header:=xlYes
'Delete the MergeKey & Source columns
ms.Range("A:B").Delete Shift:=xlLeft
'In order to be processed correctly by other functions later certain target values (Last Test Date, Last Test Value) need to be inserted as new SubMeasures (i.e. new rows)
Dim i As Long
Dim ik As String
Dim sm As String
Dim nc As String
Dim ltd As String
Dim ltv As String
Dim td As String
i = 0
fnd = True
'To add the rows we need to be able to tell when we're on the first row of data for a particular item. Meaning we need to know the column holding ItemKey
Do While ms.Range("A1").Offset(0, i).Value <> "" And fnd
Select Case LCase(ms.Range("A1").Offset(0, i).Value)
Case "itemkey"
mk = ColNumToStr(i + 1)
Case "submeasure"
sm = ColNumToStr(i + 1)
Case "numercnt"
nc = ColNumToStr(i + 1)
Case "date1"
ltd = ColNumToStr(i + 1)
Case "last_val"
ltv = ColNumToStr(i + 1)
Case "terminationdate"
td = ColNumToStr(i + 1)
End Select
i = i + 1
If sm <> "" And ik <> "" And td <> "" And ltd <> "" And nc <> "" And ltv <> "" Then
fnd = False
End If
Loop
If fnd Then
'Couldn't find the needed columns. Report the error
Call Err("Unable to locate the one or more of the following columns in the MergedCDC file: ItemKey, SubMeasure, NumerCnt, TerminationDate, Last Test Date, Last Test Value. This will prevent adding" _
& " rows for Last Test Value & Last Test Date, which will in turn mean those columns will not be correctly populated in any list based on CDC data. All other values from" _
& " the CDC data should be correct though.", sw)
Else
'Add the rows
Dim PM As String
i = 2
Do While ms.Range(mk & i).Value <> ""
If InStr(1, PM, "|" & ms.Range(mk & i).Value & "|") = 0 Then
'First row for this item set all Term Date values are set to the MAX Term Date value for the item. Also determine if they're non-compliant on any measure
Dim y As Integer
Dim tdv As Date
Dim ncv As Integer
y = 0
tdv = DateSerial(1900, 1, 1)
ncv = 1 'Start # 1 so that if any row is non-compliant we can change ncv then (as opposed to having to make sure ALL rows are compliant before setting ncv to 1)
Do While ms.Range(mk & i + y).Value = ms.Range(mk & i).Value
If ms.Range(td & i + y).Value > tdv Then
tdv = ms.Range(td & i + y).Value
End If 'else the term date is older than tdv, and we want to standardize to the max term date, so leave tdv alone
If ms.Range(nc & i + y).Value < ncv Then
ncv = 0
ElseIf ms.Range(sm & i + y).Value = "Tested" Then
'Check if the Test Value = 0 and if the Last Test Date is valid
If (ms.Range(ltd & i + y).Value = DateSerial(1900, 1, 1) Or ms.Range(ltd & i + y).Value = "" Or ms.Range(ltd & i + y).Value = BadDateRef.Value) _
And ms.Range(lbg & i + y).Value = 0 Then
'The value is 0 and the date isn't valid, that means the item wasn't actually tested (in effect if not actuality). Set this row to not tested & update ncv
ms.Range(nc & i + y).Value = 0
ncv = 0
End If 'else the item was tested, the compliance value stays the same, which means ncv doesn't need changed
End If 'Else row indicates item is compliant, which is the default, so no action needed
y = y + 1
Loop
'Replace Term Date values that aren't TDV with TDV (technically, we also replace the row that set TDV, but with the same value)
If tdv <> DateSerial(1900, 1, 1) Then
y = 0
Do While ms.Range(mk & i + y).Value = ms.Range(mk & i).Value
ms.Range(td & i + y).Value = tdv
y = y + 1
Loop
Else
'No actual date found for TDV, just clear the cells setting the format to General so that Excel doesn't re-fill in 1/1/1900
y = 0
Do While ms.Range(mk & i + y).Value = ms.Range(mk & i).Value
ms.Range(td & i + y).NumberFormat = "General"
ms.Range(td & i + y).ClearContents
y = y + 1
Loop
End If
'Copy the current row & insert two copies of it below the current row
ms.Range(i & ":" & i).Copy
ms.Range(i + 1 & ":" & i + 1).Insert Shift:=xlDown
ms.Range(i & ":" & i).Copy
ms.Range(i + 1 & ":" & i + 1).Insert Shift:=xlDown
'Change the SubMeasure cells appropriately
ms.Range(sm & i + 1).Value = "Last Test Date"
ms.Range(sm & i + 2).Value = "Last Test Val"
'Set the compliance cnt value. If the item's last value is 0 AND there is no Last Test Date value, the numercnt value for the two added rows should be 0 so that date & value
' appear (as even though they're compliant, they probably shouldn't be marked as such due to lack of proof). If the value is non-0 then set based on ncv
If ms.Range(lbg & i).Value = 0 & ms.Range(ltd & i + y).Value = "" Then
ms.Range(nc & i + 1).Value = 0
ms.Range(nc & i + 2).Value = 0
Else
ms.Range(nc & i + 1).Value = ncv
ms.Range(nc & i + 2).Value = ncv
End If
'Add the item to PM, a delimited string of ItemKeys for processed items that lets us check if we've already seen a row for this item
PM = PM & "|" & ms.Range(mk & i).Value & "|"
'Add 2 to i (this way the additional incrementing of i below results in us looking at row i + 3, which was the row that had been immediately below row i before we added the two new rows)
i = i + 2
End If 'else proceed to the next row, which happens anyway
i = i + 1
Loop
End If
'Clear out compliant rows so that MergedCDC processes through MFPRocessor (a seperate function that we're setting up the CDC data to go through) like any other source file
'(submeasure present = item non-compliant on measure)
i = 2
Do While ms.Range(mk & i).Value <> ""
If ms.Range(nc & i).Value = 1 Then
ms.Range(i & ":" & i).Delete Shift:=xlUp
Else
i = i + 1
End If
Loop
'Remove 1/1/1900 values from Last Test Date & Term Date
i = 2
Do While ms.Range(mk & i).Value <> ""
If ms.Range(ltd & i).Value = "1/1/1900" Or ms.Range(ltd & i).Value = BadDateRef.Value Then
ms.Range(ltd & i).NumberFormat = "General"
ms.Range(ltd & i).ClearContents
End If
If ms.Range(td & i).Value = "1/1/1900" Or ms.Range(td & i).Value = BadDateRef.Value Then
ms.Range(td & i).NumberFormat = "General"
ms.Range(td & i).ClearContents
End If
i = i + 1
Loop
ret = True
'Save the workbook
m.SaveAs (Replace(fpath, "CDC", "MergedCDC")) 'This code HAD worked, despite none of the changes being anything that should impact this line, this line
Application.DisplayAlerts = False
m.Close SaveChanges:=False
Application.DisplayAlerts = True
Else
'Close the new workbook without saving
m.Close SaveChanges:=False
End If
'Close the original CDC workbook
Application.DisplayAlerts = False
src.Close
Application.DisplayAlerts = True
'Capture completion of CDC merge
sw.RStat.Range("C" & sw.StatRow).Value = Now()
sw.StatRow = sw.StatRow + 1
MergeCDC = ret
End Function
If you haven't changed your code then here's a few things to check which could be causing the error:
Workbook object is out of context - ensure that you are using only one instance of Excel, if your data and workbook are in different instances then they wont be able to reach each other. When your code breaks at the error, add the workbook to your watch list to see if it reachable.
Filepath is unreachable - when the code breaks at this error, take the value of Replace(fpath, "CDC", "MergedCDC") without the filename at the end, and paste it into windows explorer and check that it is reachable.
My issue is that I am trying to extract some information from a very large data sheet. The information that is being extracted is based on some search criteria that is entered on a form. The search form counts how many occurrences of this criteria exist, but then I need to extract the individual rows into a second sheet.
The bit I'm having difficulty with is understanding how to actually structure the extraction code. I'm in need of being pointed in the right direction. If the code can count how many occurrences there are, surely I can get the row numbers for those occurrences and extract the information, I'm just not getting anywhere trying to figure it out.
Here's my SEARCH code (this code works to get the number of occurrences based on the criteria asked)
Public Sub Run_Count_Click()
'// Set Ranges
Dim Cr_1, CR1_range, _
Cr_2, CR2_range, _
Cr_3, CR3_range, _
Cr_4, CR4_range, _
Cr_5, CR5_range _
As Range
'// Set Integers
Dim CR1, V1, CR1_Result, _
CR2, V2, CR2_Result, _
CR3, V3, CR3_Result, _
CR4, V4, CR4_Result, _
CR5, V5, CR5_Result, _
total_result, _
total_result2, _
total_result3, _
total_result4, _
total_result5 _
As Integer
'Set Strings
Dim V_1, V_2, V_3, V_4, V_5 As String
Dim ws As Worksheet
Set ws = Worksheets("database")
Sheets("Settings").Range("Start_Date").Value = Format(Me.R_Start.Value, "mm/dd/yyyy")
Sheets("Settings").Range("End_Date").Value = Format(Me.R_End.Value, "mm/dd/yyyy")
'Collect Start & End Dates
Dim dStartDate As Long
Dim dEndDate As Long
dStartDate = Sheets("Settings").Range("Start_Date").Value
dEndDate = Sheets("Settings").Range("End_Date").Value
ws.Activate
On Error GoTo error_Sdate:
Dim RowNum As Variant
RowNum = Application.WorksheetFunction.Match(dStartDate, Range("B1:B60000"), 0)
'MsgBox "Found " & Format(dStartDate, "dd/mm/yyyy") & " at row : " & RowNum
On Error GoTo error_Edate:
Dim RowNumEnd As Variant
RowNumEnd = Application.WorksheetFunction.Match(dEndDate, Range("B1:B60000"), 1)
' MsgBox "Found " & Format(dEndDate, "dd/mm/yyyy") & " at row : " & RowNumEnd
GoTo J1
error_Sdate:
Dim msg As String
msg = "You entered " & Format(dStartDate, "dd/mm/yyyy") & " as your Start Date, but no referrals were made on that date"
msg = msg & vbCrLf & "Please enter a different date in the Start Date box"
MsgBox msg, , "Start Date Not Found"
Err.Clear
Exit Sub
error_Edate:
msg = "You entered " & Format(dEndDate, "dd/mm/yyyy") & " as your End Date, but no referrals were made on that date"
msg = msg & vbCrLf & "Please enter a different date in the End Date box"
MsgBox msg, , "End Date Not Found"
Err.Clear
Exit Sub
J1:
'// Get Criteria From Form And Search Database Headers
Set Cr_1 = ws.Cells.Find(What:=Me.Count_Criteria_1.Value, After:=ws.Cells(1, 1), MatchCase:=False)
If Not Cr_1 Is Nothing Then
CR1 = Cr_1.Column '//Set CR1 as the Column in which the Criteria Header was found
Else
MsgBox "Criteria 1 Has Not Been Found In The Database. Report Has Failed To Generate"
Exit Sub
End If
'// Get Variable Value From Form And Set Shortcode
V_1 = Me.Criteria_1_Variable.Value
Set CR1_range = ws.Range(ws.Cells(RowNum, CR1), ws.Cells(RowNumEnd, CR1))
CR1_Result = Application.CountIf(CR1_range, V_1)
Me.Count_Result.visible = True
Me.Count_Result.Value = "Based On Your Search Criteria Of:" & vbNewLine & vbNewLine & _
"- " & Me.Count_Criteria_1.Value & ": " & Me.Criteria_1_Variable.Value & vbNewLine & vbNewLine & _
"The Results Are: " & CR1_Result & " entries found between the dates " & Format(dStartDate, "dd/mm/yyyy") & _
" and " & Format(dEndDate, "dd/mm/yyyy")
Exit Sub
Is there an easy way of doing this with a loop? I know loops are not the best way of handling things, but Im looking for anything that works and I can tweak to suit my needs.
Thanks if you can help in advance, it's a monster of a spreadsheet!
----------------------------
*Update With Accepted Answer:*
----------------------------
Public Sub Count_Extract_Click()
'Collect Information To Be Extracted
Set ws = Worksheets("database")
Set ps = Worksheets("Extracted Rows")
ps.Range("A3:AM60000").Clear
For i = RowNum To RowNumEnd
If ws.Cells(i, CR1).Value = V_1 Then
ws.Range("A" & i & ":AM" & i).Copy
ps.Activate
'find first empty row in database
emR = ps.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
ps.Range("A" & emR & ":AM" & emR).PasteSpecial
End If
Next i
End If
End Sub
You should be able to set a For loop to check each value in the range you've found and copy it to (another cell, an array, whatever you like.)
For i = rowNum To rowNumEnd
If Cells(i,CR1).Value = V_1 Then
MsgBox "Found match on row " & i
End If
Next i
I haven't tested this, but it should work. Let me know if you get any errors.
I can't really try this out, but maybe you can. Keep the line V_1 = Me.Criteria_1_Variable.Value but replace the next 2 by :
CR1_Result = 0 'Initiates counter at 0
Dim CR1_Lines(1000) As Long 'Declares an array of 1001 (indexes 0-1000) Longs (big integers)
For x = RowNum To RowNumEnd 'Loops through all the rows of CR1
If ws.Cells(x, CR1) = V_1 Then 'Match!
'Double array size if capacity is reached
If CR1_Result = UBound(CR1_Lines) Then
ReDim Presrve CR1_Lines(UBound(CR1_Lines) * 2)
End If
'Store that line number in the array
CR1_Lines(CR1_Result) = x
'Increment count of matches
CR1_Result = CR1_Result + 1
End If
Next x 'Next row!
You can then loop through that array with this code :
For i = 0 to UBound(CR1_Lines)
'Do something! (Why not just an annoying pop-up box with the content!)
MsgBox CR1_Lines(i)
Next i
EDIT : I just read that the spreadsheet is monstruous, and re-dimensioning every time a new match is found might be neat, but it's a hell of a performance drop. I made some changes directly in the above code to make it somewhat more effective.
EDIT #2 : I've simplified code so you don't have anything to do but a copy paste (please forgive me not assuming RowNum and RowNumEnd had valid data). It should work exactly as accepted answer, but was posted a bit before and actually shows how to extract the line number. I understand if all you needed is a pop-up box with the line number, and will be satisfied with the upvote already received.