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
Related
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
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
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
I am new in VBA and want copy rows of the following worksheet based on the value of column OFFICE:
So if you notice that there are 10 rows having 4 types of office: Office-A, Office-B, Office-C, Office-D (and so on,it could be more office types ).So i want a VBA code that dynamically creates as many new sheets based on number of types of office in OFFICE column and move the rows that matched with a corresponding office type into new sheet.For: here it will look at column OFFICE and create 4 new sheets, because there 4 types of data and move corresponding rows to these sheets.Please help me to do that.Thanks
try this:
Option Explicit
Sub main()
Dim cell As Range, dataRng As Range
With Worksheets("Offices").UsedRange '<--| change "Offices" with your actual sheet name
Set dataRng = .Cells
With .Offset(, .Columns.Count).Resize(, 1)
.Value = .Parent.Columns("B").Value
.RemoveDuplicates Columns:=Array(1), Header:=xlYes
With .SpecialCells(XlCellType.xlCellTypeConstants)
For Each cell In .Offset(1).Resize(.Rows.Count - 1)
AddSheet cell.Value
With dataRng
.AutoFilter field:=2, Criteria1:=cell.Value
.SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets(cell.Value).Cells(1, 1)
End With
Next cell
End With
.Parent.AutoFilterMode = False
.Clear
End With
End With
End Sub
Sub AddSheet(shtName As String)
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(shtName)
On Error GoTo 0
If ws Is Nothing Then Worksheets.Add.Name = shtName
End Sub
This will create a new sheet for unique data in column B and rename the sheet to the cell value. You may have to adapt the code to suit your purpose.
Sub dave()
Dim dicKey, dicValues, data, lastrow As Long
Dim i As Long, ws As Worksheet, wsDest As Worksheet
Set ws = ActiveSheet
lastrow = Cells(Rows.count, 2).End(xlUp).Row
data = Range("B2:B" & lastrow) ' load data into variable
With CreateObject("scripting.dictionary")
For i = 1 To UBound(data)
If .Exists(data(i, 1)) = False Then
dicKey = data(i, 1) 'set the key
dicValues = data(i, 1) 'set the value for data to be stored
.Add dicKey, dicValues
Set wsDest = Sheets.Add(After:=Sheets(Worksheets.count))
wsDest.Name = data(i, 1)
Sheets(data(i, 1)).Cells(1, 1).Value = ws.Cells(i + 1, 2).Value
End If
Next i
End With
End Sub
I am a VBA newbie...
I am looking for value "A" in column A. I would then like to use the row number which value "A" is located at, and copy the existing function in Column F into Column E.
This is what I tried and which clearly does not work...
Dim A_Row As Long
A_Row = Application.WorksheetFunction.Match("A", Range("A:A"), 0)
Range("E" & A_Row).Select
ActiveCell.Select
ActiveCell.Offset(0, 5).Select
Selection.Copy
ActiveCell.Offset(0, -1).Select
ActiveSheet.Paste
Thank you in advance for your help!
In my opinion, if you are going to use vba then avoid using worksheet functions unless totally necessary.
Sub caroll()
Dim ws As Worksheet
Dim A_row As Long
Dim rng As Range
Set ws = ActiveSheet
'Loop through column A
For Each rng In ws.Range(ws.Cells(1, 1), ws.Cells(ws.Rows.Count, 1).End(xlUp))
'Test whether cell = "A","B", or "Z"
If VarType(rng) <> vbError Then
If rng.Value = "A" Or rng.Value = "B" Or rng.Value = "Z" Then
'If true copy column F of that row into Column E
rng.Offset(, 5).Copy rng.Offset(, 4)
End If
End If
'loop
Next rng
End Sub