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
Related
VBA Creating new sheets from unique column values in Sheet1 + bringing over adjacent row information
Hey all- I'm trying to a script that identifies the unique values in column E (data starts on row 1), creates a new sheet based on those unique values (also names the sheet per the value), and in the new sheet it creates it brings over the information corresponding rows in column A, C, D, and H -
I found this YouTube video that shows the process but instead of the script indentifying the unique values you have to manually input the keyword it is looking for and it only runs it once. I haven't been able to get the 'for loop' to run properly ...
https://www.youtube.com/watch?v=qGZQIl9JJk4&t=561s
Any help would be much appreciated-!
Private Sub CommandButton1_Click()
J = "Test"
Worksheets.Add().Name = J
Worksheets("Sheet1").Rows(1).Copy
Worksheets(J).Activate
ActiveSheet.Paste
Worksheets("Sheet1").Activate
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Sheet1").Cells(i, 5).Value = "XXXX" Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets(J).Activate
b = Worksheets(J).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(J).Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sheet1").Activate
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select
End Sub
Something like this:
Private Sub CommandButton1_Click()
Dim sht As Worksheet, c As Range, i As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
For i = 2 To sht.Cells(Rows.Count, 1).End(xlUp).Row
CopyDestination(sht.Cells(i, 5).Value).Resize(1, 5).Value = _
Array(sht.Cells(i, 5).Value, sht.Cells(i, 1).Value, _
sht.Cells(i, 3).Value, sht.Cells(i, 4).Value, _
sht.Cells(i, 8).Value)
Next
Application.CutCopyMode = False
End Sub
'Find the next "paste" destination on the appropriate sheet named "v"
' If sheet doesn't exist, create it
Function CopyDestination(v) As Range
Dim sht As Worksheet
On Error Resume Next
Set sht = ThisWorkbook.Sheets(v)
On Error GoTo 0
If sht Is Nothing Then '<< no existing matching sheet
With ThisWorkbook
Set sht = .Sheets.Add(after:=.Sheets(.Sheets.Count))
End With
sht.Name = v '<<< assumes "v" is valid as a worksheet name...
End If
'find the first empty cell in Col A
Set CopyDestination = sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Function
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
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 was trying to figure out how to have excel look at a cell in my workbook, if the cell has a value greater than 0 then copy that row into sheet2. It then looks at the next cell in the column.
Does anyone know??
I need it looking at cell I10 to start off and if I10>0 copy data from A10:K10 to sheet2 else look at I11 and repeat, then I12... until all 750+ rows are either copied or not.
Thanks so much for all the help!!!
Option Explicit
Sub Macro1()
Dim cell As Range
Dim lastRow As Long, i As Long
lastRow = Range("I" & Rows.Count).End(xlUp).Row
i = 10 ' change this to the wanted starting row in sheet2
For Each cell In Sheets(1).Range("I10:I" & lastRow)
If cell.Value > 0 Then
cell.EntireRow.Copy Sheets(2).Cells(i, 1)
i = i + 1
End If
Next
End Sub
you can use AutoFilter() method of Range object and avoid looping through cells:
Sub Main()
With Worksheets("OriginWs") '<--| change "OriginWs" to your actual data worksheet name
With .Range("I9", .Cells(.Rows.Count, "I").End(xlUp))
If IsEmpty(.Cells(1, 1)) Then .Cells(1, 1) = "dummyheader"
.AutoFilter Field:=1, Criteria1:=">0"
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .Offset(1, -8).Resize(.Rows.Count - 1, 11).SpecialCells(xlCellTypeVisible).Copy Worksheets("TargetWs").Cells(1, 1) '<--| change "TargetWs" to your actual destination worksheet name
If .Cells(1, 1).Value = "dummyheader" Then .Cells(1, 1).ClearContents
End With
.AutoFilterMode = False
End With
End Sub
BTW, the statements:
If IsEmpty(.Cells(1, 1)) Then .Cells(1, 1) = "dummyheader"
and
If .Cells(1, 1).Value = "dummyheader" Then .Cells(1, 1).ClearContents
can be avoided if your cell I9 has some text for sure
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