Below code helps to search a value entered in cell K8 and return values related to it. I need help searching multiple values, all values entered in range K8:K30 need to be searched, and records related to them need to be displayed.
Sub finddata()
Dim emstring As String
Dim finalrow As Integer
Dim i As Integer
Sheets("Sheet1").Range("P3:X37").ClearContents
emstring = Sheets("sheet1").Range("K8").Value
finalrow = Sheets("Sheet1").Range("A6000").End(xlUp).Row
For i = 2 To finalrow
If Cells(i, 2) = emstring Then
Range(Cells(i, 1), Cells(i, 3)).Copy
Range("P6000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next i
End Sub
Here you go, a nested For Loop with extra length checking:
Sub finddata()
Dim emstring As String
Dim finalrow As Integer
Dim i As Integer
Sheets("Sheet1").Range("P3:X37").ClearContents
emstring = Sheets("sheet1").Range("K8").Value
finalrow = Sheets("Sheet1").Range("A6000").End(xlUp).Row
Dim ctrSearchRow As Integer
For i = 2 To finalrow
For ctrSearchRow = 8 To 30
emstring = Sheets("Sheet1").Cells(ctrSearchRow, 11).Value
If Len(emstring) > 0 Then
If StrComp(Cells(i, 2).Value, emstring, vbTextCompare) = 0 Then
Range(Cells(i, 1), Cells(i, 3)).Copy
Range("P6000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
End If
End If
Next ctrSearchRow
Next i
End Sub
AutoFilter() use with its Operator argument set to xlFilterValues can give a help in hand here:
Sub finddata()
With Sheets("Sheet1")
.Range("P3:X37").ClearContents
With .Range("B1", .Cells(.Rows.count, 2).End(xlUp)) '<--| reference column "B" range from row 1 (header) down to last not empty row
.AutoFilter field:=1, Criteria1:=Application.Transpose(.Parent.Range("K8:K30").Value), Operator:=xlFilterValues '<--| filter on all K8:K30 values
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any filtered cell found
.Offset(1, -1).Resize(.Rows.count - 1, 3).SpecialCells(xlCellTypeVisible).Copy '<-- copy filtered range offsetted one column to the right and resized to three columns
.Parent.Cells(.Rows.count, "P").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats '<--| paste special
End If
End With
.AutoFilterMode = False
End With
End Sub
Related
I want to filter all the values except value in Array i.e. "B400", "A200", "C300".
I tried following code, none of the code is working
Dim rDataRange as Range
set rDataRange = Range("A1:P1000")
rDataRange.AutoFilter Field:=11, Criteria1:="<>" & Array("B400", "A200", "C300"), Operator:=xlFilterValues
rDataRange.AutoFilter Field:=11, Criteria1:=Array("<>B400", "<>A200", "<>C300"), Operator:=xlFilterValues
Please help me
Modified for your situation:
Option Explicit
Sub AutoFilterWorkaround()
Dim sht As Worksheet
Dim filterarr As Variant, tofindarr As Variant
Dim lastrow As Long, i As Long, j As Long, k As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'List the parts of the words you need to find here
tofindarr = Array("B400", "A200", "C300")
ReDim filterarr(0 To 0)
j = 0
For i = 2 To lastrow
If sht.Cells(i, 11).Value <> tofindarr(0) And _
sht.Cells(i, 11).Value <> tofindarr(1) And _
sht.Cells(i, 11).Value <> tofindarr(2) Then
filterarr(j) = sht.Cells(i, 11).Value
j = j + 1
ReDim Preserve filterarr(0 To j)
End If
Next i
'Filter on array
sht.Range("$A$1:$P$" & lastrow).AutoFilter Field:=11, Criteria1:=Array(filterarr), Operator:=xlFilterValues
End Sub
There is an easier way to accomplish this then using a filter.
Dim lRow As Long
With ThisWorkbook.Sheets(1)
lRow = .Range("K" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Cells(i, 11).Value = "A200" Or .Cells(i, 11).Value = "B400" Or .Cells(i, 11).Value = "C300" Then
.Cells(i, 11).EntireRow.Hidden = True
End If
Next i
End With
you could still use AutoFilter() in a sort of reverse mode:
Dim myRng As Range ' helper range variable
With Range("A1:P1000") ' reference wanted range to filter, header row included
.AutoFilter field:=11, Criteria1:=Array("B400", "A200", "C300"), Operator:=xlFilterValues ' filter on "not wanted" values
If Application.Subtotal(103, .Resize(, 1)) > 1 Then ' if any filtered cell other than header row
Set myRng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) ' temporarily set 'myRng' to referenced range "not wanted" rows
.Parent.AutoFilterMode = False ' remove filters and show all rows
myRng.EntireRow.Hidden = True ' hide referenced range "not wanted" rows, leaving "wanted" rows only visible
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) ' reference referenced range "wanted" rows
.Select
' do what you want with "wanted" rows
End With
.EntireRow.Hidden = False ' unhide all referenced range rows
Else
.Parent.AutoFilterMode = False ' remove filters
End If
End With
It's been a decade since I've written VBA and trying to reach out to see what I broke. I wrote a macro which copies data from one sheet to another, 1 column at a time for 4 different columns, and pastes it in the next free cell. This formula worked but I would like to adjust it to only copy certain data. Below is an example, I am trying to only copy A if the date value in E is equal to the input date value you enter when the macro starts. I am having most trouble balancing the If/Then with the For/Next. Every time I place an End If or Next, I receive errors.
Dim DateValue As Variant
DateValue = InputBox("Enter the date to copy")
'copy and paste column A to column A if E = input date
For Each Cell In Worksheets("Enrichment Report").Range("E:E")
If Cell.Value = DateValue Then
Sheets("Enrichment Report").Select
iMaxRow = 100
For iCol = 1 To 1
For iRow = 2 To iMaxRow
With Worksheets ("Enrichment Report").Cells(iRow, iCol)
If .Value = "" Then
'empty row, do nothing
Else
.Copy
Sheets("Intake Form").Select
Range (A" & Rows.Count).End(xlUp).Offset(1).Select
Activesheet.Paste
End If
End With
Next
End If
Next iRow
Next iCol
I think the following code will be much easier for you to follow
Also, it will be much faster looping through occupied cells with data in Column E, and not the entire column.
Code
Option Explicit
Sub Test()
Dim LastRow As Long, iMaxRow As Long, iCol As Long, iRow As Long
Dim DateValue As Variant
Dim Cell As Range
DateValue = InputBox("Enter the date to copy")
With Worksheets("Enrichment Report")
' get last row with data in column E
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
'copy and paste column A to column A if E = input date
For Each Cell In .Range("E1:E" & LastRow)
If Cell.Value = DateValue Then
iMaxRow = 100
For iCol = 1 To 1
For iRow = 2 To iMaxRow
If .Cells(iRow, iCol).Value = "" Then
'empty row, do nothing
Else
.Cells(iRow, iCol).Copy
Sheets("Intake Form").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteAll
End If
Next iRow
Next iCol
End If
Next Cell
End With
End Sub
you could use AutoFilter() and avoid looping
also, use Application.InputBox() method instead of VBA InputBox() function to exploit its Type parameter and force a numeric input
Sub mmw()
Dim targetSht As Worksheet
Set targetSht = Sheets("Intake Form")
Dim DateValue As Variant
DateValue = Application.InputBox("Enter the date to copy", , , , , , , 2)
With Worksheets("Enrichment Report") ' reference your "source" sheet
With .Range("A1", .Cells(.Rows.Count, "E").End(xlUp)) ' reference its columns A:E cells from row 1 down to column E last not empty cell
.AutoFilter Field:=1, Criteria1:="<>" 'filter on referenced range 1st column with not empty cells
.AutoFilter Field:=5, Criteria1:=CStr(CDate(DateValue))
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then _
.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy _
Sheets("Intake Form").Cells(Sheets("Intake Form").Rows.Count, "A").End(xlUp).Offset(1) '<--| if any cell filtered other than headers (which get always filtered) then copy filtered values to "paste" sheet
End With
.AutoFilterMode = False
End With
End Sub
Obviously, with the proper indentation done by CallumDA, it should be written as below. Also there is a typo in the Range (A", it should be Range ("A":
For Each Cell In Worksheets("Enrichment Report").Range("E:E")
If Cell.Value = DateValue Then
Sheets("Enrichment Report").Select
iMaxRow = 100
For iCol = 1 To 1
For iRow = 2 To iMaxRow
With Worksheets ("Enrichment Report").Cells(iRow, iCol)
If .Value = "" Then
'empty row, do nothing
Else
.Copy
Sheets("Intake Form").Select
Range ("A" & Rows.Count).End(xlUp).Offset(1).Select
Activesheet.Paste
End If
End With
Next iRow
Next iCol
End If
Next
I have two columns in a sheet "test". Let's assume col C and D.
Each rows in C and D might have either "COMPATIBLE" or "NOT DETERMINED" or Blank cell.
I want to compare col C and D,and if C has "COMPATIBLE" and D has "NOT DETERMINED", then "COMPATIBLE" should be paste into D and vice versa.
I have below code, But not sure how to complete it:
Sub compare_cols()
'Get the last row
Dim Report As Worksheet
Dim i As Integer, j As Integer
Dim lastRow As Integer
Set Report = Excel.Worksheets("test") 'You could also use Excel.ActiveSheet _
if you always want this to run on the current sheet.
lastRow = Report.UsedRange.Rows.Count
Application.ScreenUpdating = False
For i = 2 To lastRow
For j = 2 To lastRow
If Report.Cells(i, 1).Value = "COMPATIBLE" Then
If InStr(1, Report.Cells(j, 2).Value, Report.Cells(i, 1).Value, vbTextCompare) > 0
UPDATING THE WORK IN PROGRESS CODE:
Option Explicit
Sub compare_cols()
With Worksheets("Latency") '<-.-| reference your worksheet
With .Range("F1:G" & .UsedRange.Rows(.UsedRange.Rows.count).Row) '<--| reference its columns C:D range from row 1 down to worksheet last used row
Correct .Cells, "COMPATIBLE", "Not Determind", 2
Correct .Cells, "Determind", "COMPATIBLE", 1
End With
.AutoFilterMode = False
End With
End Sub
Sub Correct(rng As Range, val1 As String, val2 As String, colToChangeIndex As Long)
With rng '<--| reference passed range
.AutoFilter Field:=1, Criteria1:=val1 '<--| filter referenced range on its 1st column with 'val1'
.AutoFilter Field:=2, Criteria1:=val2 '<--| filter referenced range on its 2nd column with 'val2'
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any filterd cells other than header
.Resize(.Rows.count - 1, 1).Offset(1, colToChangeIndex - 1).SpecialCells(xlCellTypeVisible).Value = "COMPATIBLE" '<--| write "COMPATIBLE" in column "D"
End If
End With
End Sub
Try this code
Sub CvalueAndDvalue()
Dim cValue As Range, dValue As Range
Dim Report As Worksheet
Set Report = Excel.Worksheets("test")
For i = 2 To Report.Range("C" & Rows.Count).End(xlUp).Row
Set cValue = Report.Range("C" & i)
Set dValue = Report.Range("D" & i)
If (Trim(cValue) = "COMPATIBLE" And Trim(dValue) = "NOT DETERMINED") Then
dValue = cValue
ElseIf (Trim(dValue) = "COMPATIBLE" And Trim(cValue) = "NOT DETERMINED") Then
cValue = dValue
End If
Next i
End Sub
you could use AutoFilter():
Option Explicit
Sub compare_cols()
With Worksheets("test") '<-.-| reference your worksheet
With .Range("C1:D" & .UsedRange.Rows(.UsedRange.Rows.Count).Row) '<--| reference its columns C:D range from row 1 down to worksheet last used row
Correct .Cells, "COMPATIBLE", "NOT DETERMINED", 2
Correct .Cells, "NOT DETERMINED", "COMPATIBLE", 1
End With
.AutoFilterMode = False
End With
End Sub
Sub Correct(rng As Range, val1 As String, val2 As String, colToChangeIndex As Long)
With rng '<--| reference passed range
.AutoFilter Field:=1, Criteria1:=val1 '<--| filter referenced range on its 1st column with 'val1'
.AutoFilter Field:=2, Criteria1:=val2 '<--| filter referenced range on its 2nd column with 'val2'
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any filterd cells other than header
.Resize(.Rows.Count - 1, 1).Offset(1, colToChangeIndex - 1).SpecialCells(xlCellTypeVisible).Value = "COMPATIBLE" '<--| write "COMPATIBLE" in column "D"
End If
End With
End Sub
I'm trying to remove duplicate rows in my Excel Sheet using Visual Basic. The problem is that the amount of Rows will be variable.
Sub RemoveDuplicates()
Range("A1").Select
ActiveSheet.Range(Selection, ActiveCell.CurrentRegion).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
End Sub
The problem here is that Columns:=Array(1, 2) isn't a variable. It should always look from column 1 until the last filled column (the .CurrentRegion).
Can someone please help me!
One way is to create the array dynamically.
Once the block has been defined, we know exactly how many columns the block contains:
Sub luxation()
Dim A1 As Range, rng As Range, cCount As Long
Set A1 = Range("A1")
Set rng = A1.CurrentRegion
cCount = rng.Columns.Count - 1
ReDim ary(0 To cCount)
For i = 0 To cCount
ary(i) = i + 1
Next i
rng.RemoveDuplicates Columns:=(ary), Header:=xlYes
End Sub
Note the encapsulation of ary() in the last line!
Gary's Student has the correct answer.
I'm just having a little fun:
Dim a As Variant
With Range("A1").CurrentRegion
a = Evaluate("Transpose(Row(1:" & .Columns.Count & "))")
ReDim Preserve a(0 To UBound(a) - 1)
.RemoveDuplicates Columns:=(a), Header:=xlYes
End With
Maybe you want something like this:
Sub RemoveDuplicates()
Dim LastCol As Long
Dim LastRow As Long
Dim ColArray As Variant
Dim i As Long
' modify "Sheet1" to your sheet's name
With Sheets("Sheet1")
' find last column with data in first row ("header" row)
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
' find last row with data in column "A"
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim ColArray(0 To LastCol - 1)
For i = 0 To UBound(ColArray)
ColArray(i) = i + 1
Next i
.Range(.Cells(1, 1), .Cells(LastRow, LastCol)).RemoveDuplicates Columns:=(ColArray), Header:=xlYes
End With
End Sub
I'm using this code to take a username an search for all of their associate info from multiple transactions. It should then paste them into the current worksheet. It seems to run, in that it doesn't throw up any errors and it executes the final "Select" command, but it doesn't return any pasted data.
Option Explicit
Sub InvestorReport()
Dim investorname As String
Dim finalrow As Integer
Dim i As Integer 'row counter
Sheets("Sheet1").Range("D6:K50").ClearContents
investorname = Sheets("Sheet1").Range("B3").Value
finalrow = Sheets("Investments").Range("I1000").End(xlUp).Row
For i = 2 To finalrow
If Sheets("Investments").Cells(i, 1) = investorname Then
MsgBox ("Works")
Range(Cells(i, 2), Cells(i, 12)).Copy
Sheets("Sheet1").Range("D100").End(xlUp).Offset(1, 0).PasteSpecial
End If
Next i
Range("B3").Select
End Sub
this is the code to properly reference sheets:
Option Explicit
Sub InvestorReport()
Dim investorname As String
Dim finalrow As Long
Dim i As Long 'row counter
With Sheets("Sheet001") '<--| refer to "Sheet1" sheet
.Range("D6:K50").ClearContents '<--| with every initial "dot" you keep referencing the object after the "With" keyword ("Sheet1" sheet, in this case)
investorname = .Range("B3").value
End With
With Sheets("Investments") '<--| refer to "Investments" sheet
finalrow = .Cells(.Rows.Count, "I").End(xlUp).row '<--| .Cells and .Rows refer to "Investments" sheet
For i = 2 To finalrow
If .Cells(i, 1) = investorname Then
.Range(.Cells(i, 2), .Cells(i, 12)).Copy '<--| .Range and .Cells refer to "Investments" sheet
Sheets("Sheet001").Range("D100").End(xlUp).Offset(1, 0).PasteSpecial '<--| here all references are explicitly made to "Sheet1" sheet
End If
Next i
End With
Sheets("Sheet001").Range("B3").Select
End Sub
and here follows the code to avoid loops and exploiting Autofilter:
Sub InvestorReport2()
Dim investorname As String
Dim finalrow As Long
Dim i As Long 'row counter
With Sheets("Sheet001") '<--| refer to "Sheet1" sheet
.Range("D6:K50").ClearContents '<--| with every initial "dot" you keep referencing the object after the "With" keyword ("Sheet1" sheet, in this case)
investorname = .Range("B3").value
End With
With Sheets("Investments") '<--| refer to "Investments" sheet
With .Range("A1", .Cells(.Rows.Count, "L").End(xlUp)) '<--| refer to "Investments" sheet columns A to I fom row 1 (header) down to last non empty one in column I
.AutoFilter field:=1, Criteria1:=investorname '<--| filter data on first column values matching "investorname"
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell has been filtered...
.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).SpecialCells(xlCellTypeVisible).Copy '<--| ... copy filtered cells skipping headers and first column...
Sheets("Sheet001").Range("D100").End(xlUp).Offset(1, 0).PasteSpecial '<--| ...and paste them
End If
End With
.AutoFilterMode = False '<--| .. show all rows back...
End With
Sheets("Sheet001").Range("B3").Select
End Sub