I have an existing VBA code that copies rows if an identifier column is marked with 'X'. Now I want it to be based off a date range entered by the user. Can somebody please help me convert the existing code to my required one? Thanks!
Sub CopyRow()
Application.ScreenUpdating = False
Dim x As Long, MaxRowList As Long, MaxRowList2 As Long, S As String, wsSource As Worksheet, wsTarget As Worksheet, S2 As Long
Set wsSource = ThisWorkbook.Worksheets("Sheet 1 - RAW")
Set wsTarget = ThisWorkbook.Worksheets("Staging")
iCol = 1
MaxRowList = wsSource.Cells(Rows.Count, iCol).End(xlUp).Row
MaxRowList2 = wsTarget.Cells(Rows.Count, iCol).End(xlUp).Row
S2 = 8
wsTarget.Range("A8:H22").ClearContents
For x = 4 To MaxRowList
If InStr(1, wsSource.Cells(x, 19), "X") Then
wsTarget.Cells(S2, 1).Value = wsSource.Cells(x, 1).Value
wsTarget.Cells(S2, 4).Value = wsSource.Cells(x, 2).Value
wsTarget.Cells(S2, 5).Value = wsSource.Cells(x, 10).Value
wsTarget.Cells(S2, 6).Value = wsSource.Cells(x, 16).Value
wsTarget.Cells(S2, 7).Value = wsSource.Cells(x, 18).Value
wsTarget.Cells(S2, 8).Value = wsSource.Cells(x, 17).Value
S2 = S2 + 1
End If
Next
Application.ScreenUpdating = True
End Sub
You need to modify your if Statement.
If InStr(1, wsSource.Cells(x, 19), "X") Then
Will become
If wsSource.Cells(x, ColumnThatContainsTheDate).value > OlderDate and wsSource.Cells(x, 19).value < NewerDate Then
Now, your problem will become how do you want the user to select the dates? A form that he could dynamically select (using a calendar), just a plain input box or based on a value of a cell? Do you want everything that is older or newer to this date or do you want between two dates? Just adjust the statement to whatever suits your needs.
Related
I am new to VBA and I will need a help.
I have a worksheet named "Jobs" with raw data table and I want to copy paste certain cells to another worksheet named "Schedule" provided that the source and destination date matches and I use the below. But, I have 3 jobs for the same date and it copy only one. Any help will be appreciated.
Sub CopyBasedonSheet1()
Dim i As Long
Dim j As Long
Worksheets("Schedule").Range("B1:AJ92").ClearContents
Sheet1LastRow = Worksheets("Jobs").Range("G" & Rows.Count).End(xlUp).Row 'G is the Date Column'
Sheet2LastRow = Worksheets("Schedule").Range("A" & Rows.Count).End(xlUp).Row 'A is the Date column'
For j = 1 To Sheet1LastRow
For i = 1 To Sheet2LastRow
If Worksheets("Jobs").Cells(j, 7).Value = Worksheets("Schedule").Cells(i, 1).Value And Worksheets("Jobs").Cells(j, 1).Value = "P" Then
Worksheets("Schedule").Cells(i, 2).Value = Worksheets("Jobs").Cells(j, 3).Value
Worksheets("Schedule").Cells(i, 3).Value = Worksheets("Jobs").Cells(j, 9).Value
Worksheets("Schedule").Cells(i, 4).Value = Worksheets("Jobs").Cells(j, 14).Value
End If
Next i
Next j
End Sub
I am New to VBA, so my codes are usually very slow/suboptimized.
In one of my programs I have cells in the sheet that has to be filled when the user press a button, the renges change depending on the button but the concept is the same.
So I did this monstrosity:
Cells((Range("namedrange").Row + 5), 1).Value = ThisWorkbook.Sheets(5).Cells(4, 7).Value
Cells((Range("namedrange").Row + 5), 3).Value = ThisWorkbook.Sheets(5).Cells(4, 8).Value
Cells((Range("namedrange").Row + 5), 5).Value = ThisWorkbook.Sheets(5).Cells(4, 9).Value
Cells((Range("namedrange").Row + 5), 8).Value = ThisWorkbook.Sheets(5).Cells(4, 10).Value
Cells((Range("namedrange").Row + 5) + 1, 1).Value = ThisWorkbook.Sheets(5).Cells(5, 7).Value
Cells((Range("namedrange").Row + 5) + 1, 3).Value = ThisWorkbook.Sheets(5).Cells(5, 8).Value
Cells((Range("namedrange").Row + 5) + 1, 5).Value = ThisWorkbook.Sheets(5).Cells(5, 9).Value
Cells((Range("namedrange").Row + 5) + 1, 8).Value = ThisWorkbook.Sheets(5).Cells(5, 10).Value
but later changed to:
With Range("namedrange")
.Offset(5).Columns(1).Value = ThisWorkbook.Sheets(3).Cells(4, 7).Value
.Offset(5).Columns(3).Value = ThisWorkbook.Sheets(3).Cells(4, 8).Value
.Offset(5).Columns(5).Value = ThisWorkbook.Sheets(3).Cells(4, 9).Value
.Offset(5).Columns(8).Value = ThisWorkbook.Sheets(3).Cells(4, 10).Value
.Offset(6).Columns(1).Value = ThisWorkbook.Sheets(3).Cells(5, 7).Value
.Offset(6).Columns(3).Value = ThisWorkbook.Sheets(3).Cells(5, 8).Value
.Offset(6).Columns(5).Value = ThisWorkbook.Sheets(3).Cells(5, 9).Value
.Offset(6).Columns(8).Value = ThisWorkbook.Sheets(3).Cells(5, 10).Value
End With
which is a bit faster, however I feel that it is still suboptimized. And I would like to know if there is a way to make it cleaner/more elegant.
Just to be noted that there are discontinuities in the columns, e.g. it starts in the 1st columns but jumps to the 3rd and then to the 5th and at last to the 8th.
The code works but it is slow, I just want a way to make it faster/cleaner.
Using Variables
In regards to efficiency, that's about it: you're using the most efficient way to copy values from one cell to another aka copying by assignment.
If you want it to be more flexible, maintainable, and readable(?), here are some ideas.
Additionally, you can move the remaining magic numbers and text to constants at the beginning of the code or even use the constants as arguments.
Sub CopyValues()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Specify the worksheet if you know it.
'Dim dnrg As Range: Set dnrg = wb.Sheets("Sheet1").Range("NamedRange")
' Otherwise, make sure the workbook is active.
If Not wb Is ActiveWorkbook Then wb.Activate
Dim dnrg As Range: Set dnrg = Range("NamedRange")
Dim drg As Range: Set drg = dnrg.Range("A1,C1,E1,H1").Offset(5)
Dim cCount As Long: cCount = drg.Cells.Count
' If you know the tab name, use it instead of the index (3).
Dim sws As Worksheet: Set sws = wb.Sheets(3)
Dim srg As Range: Set srg = sws.Range("G4").Resize(, cCount)
Dim r As Long, c As Long
For r = 0 To 1
For c = 1 To cCount
drg.Offset(r).Cells(c).Value = srg.Offset(r).Cells(c).Value
Next c
Next r
End Sub
Accessing Excel for values from VBA is a slow operation and this adds up when you make multiple requests. When you are essentially retrieving the same information on a repetitive basis there are two two methods can be used to reduce access times.
Replace a lookup with a calculated value
Use a with statement
Thus you code could be written as
Dim myCol as long
myCol =Range("namedrange").Row + 5
With ThisWorkook.Sheets(5)
Cells(myCol, 1).Value = .Cells(4, 7).Value
Cells(myCol, 3).Value = .Cells(4, 8).Value
Cells(myCol, 5).Value = .Cells(4, 9).Value
Cells(myCol, 8).Value = .Cells(4, 10).Value
myCol=myCol+1 ' trivial example
Cells(mycol, 1).Value = .Cells(5, 7).Value
Cells(myCol, 3).Value = .Cells(5, 8).Value
Cells(myCol, 5).Value = .Cells(5, 9).Value
Cells(myCol, 8).Value = .Cells(5, 10).Value
End with
Please also install the free, opensource, and fantastic Rubberduck addin for VBA. The code inspections will help you write VBA that is much more correct.
I wonder what would happen if you use all the .Offset parameters, row and column. Example:
With Range("namedrange")
.Offset(5, 0).Value = ThisWorkbook.Sheets(3).Cells(4, 7).Value
.Offset(5, 2).Value = ThisWorkbook.Sheets(3).Cells(4, 8).Value
.Offset(5, 4).Value = ThisWorkbook.Sheets(3).Cells(4, 9).Value
.Offset(5, 7).Value = ThisWorkbook.Sheets(3).Cells(4, 10).Value
.Offset(6, 0).Value = ThisWorkbook.Sheets(3).Cells(5, 7).Value
.Offset(6, 2).Value = ThisWorkbook.Sheets(3).Cells(5, 8).Value
.Offset(6, 4).Value = ThisWorkbook.Sheets(3).Cells(5, 9).Value
.Offset(6, 7).Value = ThisWorkbook.Sheets(3).Cells(5, 10).Value
End With
You can try to disable screenupdating during execution.
Disable ScreenUpdating
To disable ScreenUpdating, at the beginning of your code put this line:
Application.ScreenUpdating = False
Enable ScreenUpdating
To re-enable ScreenUpdating, at the end of your code put this line:
Application.ScreenUpdating = True
it should be simple to make, but it doesn't work. My Column 6 from data list with dates is in that format "mmm.yyyy".
I become always all rows in my list, but i want only those with date older than today.
Only that part of statement work And ws.Cells(i, 6).Value <> vbNullString
Sub PopulateList2()
Dim rngName As Range
Dim ws As Worksheet
Dim i As Integer
Dim LastRow As Long
Set ws = E1G
AbgeListField.Clear
AbgeListField.ColumnCount = 2
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
For i = 1 To LastRow
'If statement to get Cells(i, 6).value and check it with Date(now).
If Format(Cells(i, 6), "mmm.yyyy").Value < Format(Now(), "mmm.yyyy") _
And ws.Cells(i, 6).Value <> vbNullString Then
AbgeListField.AddItem ws.Cells(i, 1).Value
AbgeListField.List(i - 1, 1) = ws.Cells(i, 2).Value
AbgeListField.List(i - 1, 2) = ws.Cells(i, 3).Value
End If
Next i
End Sub
Format vs Value
Maybe I misunderstood but this code should work fine:
If ws.Cells(i, 6).Value < Now() _
And ws.cells(i, 6).value <> vbNullString Then
It couldn't work with format, because format turns a value into a string. Then you would have to use the CDate conversion function to get it back to a date, but what's the use of that when you already have a date.
There are three ways of returning or setting a cell value e.g.
let's use 3rd October 2018 in cell 'A1'
Cells("A1").Value returns '3.10.2018' (Maybe different depending on the system settings)
Cells("A1").Value2 returns '43376'
Cells("A1").Text returns in your example 'Oct 2018'
If you use 'Value' it will always, regardless of your formatting, use the 'Value', not the 'Text'.
If you got lost on the way you can always convert Now() and ws.Cells(i, 6).Value to a double type to make sure numbers are being compared:
If CDbl(ws.Cells(i, 6).Value) < CDbl(Now()) _
And ws.cells(i, 6).Value <> vbNullString Then
Im trying to write a VBA script to compare two = rows and have the spreadsheet highlight the duplicate rows only if certain criteria is met, such as (Value of row, column a = Value of row-1, column) AND Value of row, column b > Value of row-1, column b) Then entirerow of the greater value in column b.font.color = vbRed.
Here is a section of the table I'm running...
Table Selection
Here is the code I am using...
Sub RemoveDuplicates()
Dim i As Long, R As Long
'Dim DeviceName As Range, SerialNumber As Range, LastContact As Range
Application.ScreenUpdating = False
R = Cells(Rows.Count, 1).End(xlUp).Row
'Set DeviceName = Columns(2)
'Set SerialNumber = Columns(3)
'Set LastContact = Columns(7)
For i = R To 2 Step -1
'If Cells(i, "F").Value > Cells(i - 1, "F").Value Then
'Code above doesn't work
If Cells(i, 3).Value = Cells(i - 1, 3).Value And Cells(i, 2).Value = Cells(i - 1, 2).Value Then
'If Cells(i, 3).Value = Cells(i - 1, 3).Value And Cells(i, 2).Value = Cells(i - 1, 2).Value And Cells(i, 5).Value > Cells(i - 1, 5).Value Then
'Code above doesn't work
Cells(i, 1).EntireRow.Font.Color = vbRed
End If
Next i
Application.ScreenUpdating = True
End Sub
I can get the duplicates to highlight, but when I try to introduce the greater than check, the system gets janky.
try a conditional formatting rule.
With worksheets("sheet1").usedrange.offset(1, 0).entirerow
.FormatConditions.Delete
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=and($a2=$a1, $b2=$b1, $f2>$f1)")
.font.Color = vbRed
End With
End With
I am trying to write a code that will take one cell and then iterate through another column to find a match, once it has found a match it will then match two other cells in that same row and return the value of a 5th and 6th cell. However, it is not working! any suggestions??
Sub rates()
Dim i As Integer
For i = 2 To 2187
If Cells(i, 1).Value = Cells(i, 11).Value Then
If Cells(i, 2).Value = Cells(i, 12).Value Then
Cells(i, 20) = Cells(i, 1).Value
Cells(i, 21) = Cells(i, 11).Value
Cells(i, 22) = Cells(i, 4).Value
Cells(i, 23) = Cells(i, 16).Value
Else
Cells(i, 24) = "No match"
End If
End If
Next i
End Sub
Try fully qualifying your cell objects i.e. sheet1.cells(i,1).value etc or encase within a with statement i.e.
with sheet1
if .cells(i,X) = .cells(i,Y) then
'...etc
end with
I think the default property for a range is "Value" but try putting .Value on to the end of all those Cell lines too... like you have for half of them :)
[EDIT/Addition:]
... failing that, you're not actually searching a whole column at any point: try something like:
Sub rates()
Dim i As Integer
Dim rgSearch As Range
Dim rgMatch As Range
Dim stAddress As String
Dim blMatch As Boolean
With wsSheet
Set rgSearch = .Range(.Cells(x1, y1), .Cells(x2, y2)) ' Replace where appropriate (y = 1 or 11 i guess, x = start and end row)
End With
For i = 2 To 2187
Set rgMatch = rgSearch.Find(wsSheet.Cells(i, y)) ' y = 1 or 11 (opposite of above!)
blMatch = False
If Not rgMatch Is Nothing Then
stAddress = rgMatch.Address
Do Until rgMatch Is Nothing Or rgMatch.Address = stAddress
If rgMatch.Offset(0, y).Value = Cells(i, 12).Value Then
Cells(i, 20) = Cells(i, 1).Value
Cells(i, 21) = Cells(i, 11).Value
Cells(i, 22) = Cells(i, 4).Value
Cells(i, 23) = Cells(i, 16).Value
blMatch = True
Else
End If
Set rgMatch = rgSearch.FindNext(rgMatch)
Loop
End If
If Not blMatch Then
Cells(i, 24) = "No match"
End If
Next i
End Sub
I've made a lot of assumptions in there and there's a few variables you'll have to replace. You could also probably use application.worksheetfunction.match but .find is quicker and more awesome