I've been toying with this very simple code and am completely baffled. Below are three different variations I have tried in order to figure out the issue and none have worked.
Original Code:
Sub GetResults()
Set Result = ActiveWorkbook.Worksheets("Results")
Set UTDT = ActiveWorkbook.Worksheets("UTDT")
Set RADAR = ActiveWorkbook.Worksheets("RADAR")
Dim y As Long
Dim i As Long
Dim x As Long
For x = 2 To RADAR.UsedRange.Rows.Count
For i = 2 To UTDT.UsedRange.Rows.Count
For y = 2 To Result.UsedRange.Rows.Count
If UTDT.Cells(i, 1) = RADAR.Cells(x, 1) And UTDT.Cells(i, 25) <> RADAR.Cells(x, 2) Then
Result.Cells(y, 1) = Trim(UTDT.Cells(i, 1))
Result.Cells(y, 2) = UTDT.Cells(i, 2)
Result.Cells(y, 3) = UTDT.Cells(i, 3)
Result.Cells(y, 4) = "Update"
End If
Next y
Next i
Next x
End Sub
I then remove the and portion and added a message box to simplify it:
Sub GetResults()
Set Result = ActiveWorkbook.Worksheets("Results")
Set UTDT = ActiveWorkbook.Worksheets("UTDT")
Set RADAR = ActiveWorkbook.Worksheets("RADAR")
Dim y As Long
Dim i As Long
Dim x As Long
For x = 2 To RADAR.UsedRange.Rows.Count
For i = 2 To UTDT.UsedRange.Rows.Count
For y = 2 To Result.UsedRange.Rows.Count
If UTDT.Cells(i, 1) = RADAR.Cells(x, 1) Then
MsgBox ("It WORKED!")
End If
Next y
Next i
Next x
End Sub
Still skips the IF statement. So i decided ill change it to <> in case its skipping because invisible formatting is causing it to be false.. but still no luck:
Sub GetResults()
Set Result = ActiveWorkbook.Worksheets("Results")
Set UTDT = ActiveWorkbook.Worksheets("UTDT")
Set RADAR = ActiveWorkbook.Worksheets("RADAR")
Dim y As Long
Dim i As Long
Dim x As Long
For x = 2 To RADAR.UsedRange.Rows.Count
For i = 2 To UTDT.UsedRange.Rows.Count
For y = 2 To Result.UsedRange.Rows.Count
If UTDT.Cells(i, 1) <> RADAR.Cells(x, 1) Then
MsgBox ("It WORKED!")
End If
Next y
Next i
Next x
End Sub
Related
The code is not working in this way, but if i use ('Wks_So.Range("A9:A150").ClearContents), instead of (Wks_So.Range("A9", Range("A9").End(xlDown)).ClearContents), the code has no problem at all.
My aim for the selection is to clear all the contents from A9 to the last cell of column A with values
Dim i As Integer
Dim j As Integer
Dim x As Integer
Application.Calculation = xlCalculationManual
Set Wks_Sb = Worksheets("Scarico_Bond")
Set Wks_So = Worksheets("Scarico_Other")
Set Wks_I = Worksheets("Invio")
Wks_Sb.Range("A9", Range("A9").End(xlDown)).ClearContents
'Wks_Sb.Range("A9:A150").ClearContents
Wks_So.Range("A9", Range("A9").End(xlDown)).ClearContents
here is the error
'Wks_So.Range("A9:A50").ClearContents
Wks_Sb.Range("D9:D140").Interior.Color = vbWhite
j = 9
k = 9
x = 8
For i = 7 To 150
If InStr(1, (Wks_I.Cells(i, 4).Value), "Obbligazioni") > 0 Then
Wks_Sb.Cells(j, 1) = x - 7
j = j + 1
Else
If InStr(1, (Wks_I.Cells(i, 4).Value), "Fondi/ETF") > 0 Then
Wks_So.Cells(k, 1) = x - 7
k = k + 1
End If
End If
x = x + 1
Next i
Application.Calculation = xlCalculationAutomatic
End Sub
I would do like this and also define some variables:
Sub yourSub()
Dim i, j, k, x As Integer
Dim lastRow_Sb, lastRow_So, lastRow_I as Integer
Dim wb As Workbook
Dim Wks_Sb, Wks_So, Wks_I As Worksheet
Set wb = ActiveWorkbook
Set Wks_Sb = wb.Worksheets("Scarico_Bond")
Set Wks_So = wb.Worksheets("Scarico_Other")
Set Wks_I = wb.Worksheets("Invio")
lastRow_Sb = Wks_Sb.Cells.SpecialCells(xlLastCell).Row
lastRow_So = Wks_So.Cells.SpecialCells(xlLastCell).Row
lastRow_I = Wks_I.Cells.SpecialCells(xlLastCell).Row
Application.ScreenUpdating = False
Wks_Sb.Range("A9:A" & lastRow_Sb).ClearContents
Wks_So.Range("A9:A" & lastRow_So).ClearContents
Wks_Sb.Range("D9:D140").Interior.Color = vbWhite
j = 9
k = 9
x = 8
For i = 7 To lastRow_I 'Or should this always be 150?
If InStr(1, (Wks_I.Cells(i, 4).Value), "Obbligazioni") > 0 Then
Wks_Sb.Cells(j, 1) = x - 7
j = j + 1
Else
If InStr(1, (Wks_I.Cells(i, 4).Value), "Fondi/ETF") > 0 Then
Wks_So.Cells(k, 1) = x - 7
k = k + 1
End If
End If
x = x + 1
Next i
Application.ScreenUpdating = True
End Sub
You should use End(xlUp) instead of twice End(xlDown):
Change
Wks_Sb.Range("A9", Range("A9").End(xlDown)).ClearContents
'Wks_Sb.Range("A9:A150").ClearContents
Wks_So.Range("A9", Range("A9").End(xlDown)).ClearContents
to:
Wks_Sb.Range("A9", Wks_Sb.Range("A1000000").End(xlUp)).ClearContents
I'm trying to code an analysis that will count certain cells in a data set and color code them based on their relative values. I have the counter code finished, but am now trying to get a subprocedure for the coloring to work. I've been able to achieve this in a stand alone sub procedure that has a manually entered range (ie "b2:e44") however, this isn't super useful as I will be applying this code to many datasets that vary in size.
I was able to code into the function a variable range called "datarange" that changes based on the entered datarange, but when I try to call the datarange and max variables into the subprocedure, it doesn't work.
How do I continue using the function variables in the subprocedure?
This is what I have so far:
Function breadthreport(datarange As Range, max As Variant, increase As String)
'counters
Dim cf1 As Variant
cf1 = 0
Dim cf2 As Variant
cf2 = 0
Dim cf3 As Variant
cf3 = 0
Dim cf4 As Variant
cf4 = 0
'cell variables
Dim x As Variant
Dim y As Variant
'no room for improvement
For x = 1 To datarange.Rows.Count Step 2
For y = 1 To datarange.Columns.Count
If datarange(x, y) = datarange(x + 1, y) And datarange(x, y) = max Then
cf1 = cf1 + 1
Else
End If
Next y
Next x
'stagnant cohort
For x = 1 To datarange.Rows.Count Step 2
For y = 1 To datarange.Columns.Count
If datarange(x, y) = datarange(x + 1, y) Then
cf2 = cf2 + 1
Else
End If
Next y
Next x
'worsening cohorts
For x = 1 To datarange.Rows.Count Step 2
For y = 1 To datarange.Columns.Count
If increase = "improvement" Then
If datarange(x, y) > datarange(x + 1, y) Then
cf3 = cf3 + 1
Else
End If
ElseIf increase = "worsening" Then
If datarange(x, y) < datarange(x + 1, y) Then
cf3 = cf3 + 1
Else
End If
Else
End If
Next y
Next x
'success cohorts
For x = 1 To datarange.Rows.Count Step 2
For y = 1 To datarange.Columns.Count
If increase = "improvement" Then
If datarange(x, y) < datarange(x + 1, y) Then
cf4 = cf4 + 1
Else
End If
ElseIf increase = "worsening" Then
If datarange(x, y) > datarange(x + 1, y) Then
cf4 = cf4 + 1
Else
End If
Else
End If
Next y
Next x
'define your array
Dim ret(3, 1) As Variant
Dim labels(3, 0) As String
'insert a sub to color the labels
breadthcolor datarange, max, increase
'labels
ret(0, 0) = "Stagnant Max Cohort"
ret(1, 0) = "Stagnant Cohort"
ret(2, 0) = "Worsening Cohort"
ret(3, 0) = "Success Cohort"
'assign values
ret(0, 1) = cf1
ret(1, 1) = cf2
ret(2, 1) = cf3
ret(3, 1) = cf4
breadthreport = ret
End Function
Sub breadthcolor(subrange As Range, submax As Variant, subincrease As String)
MsgBox "youre in the sub"
'cell variables
Dim x As Variant
Dim y As Variant
'no room for improvement
For x = 1 To subrange.Rows.Count Step 2
For y = 1 To subrange.Columns.Count
For Each cell In subrange
If cell(x, y).Value = cell(x + 1, y).Value Then
cell.Interior.color = vbGreen
Else
End If
Next
Next y
Next x
'the rest of the sub will mirror the counter function but with color changes rather than counters
End Sub
Ideally this can be done using the datarange defined in the function, I'm sharing this code with my team who have no background in coding and will not be able to manually edit the range in the procedure.
This code copies the entire row to another when the word 'ordered' is in a certain column.
However, I need to adapt this code to not copy the entire row for another function but requires only copying columns A:J over into the next sheet but I'm having difficulty achieving this.
Sub MovingOrderedItems()
Dim xRg As Range
Dim xCell As Range
Dim X As Long
Dim Y As Long
Dim Z As Long
X = Worksheets("Engineer-Items to be ordered").UsedRange.Rows.Count
Y = Worksheets("Admin").UsedRange.Rows.Count
If Y = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Admin").UsedRange) = 0 Then Y = 0
End If
Set xRg = Worksheets("Engineer-Items to be ordered").Range("N3:N" & X)
On Error Resume Next
Application.ScreenUpdating = False
For Z = 1 To xRg.Count
If CStr(xRg(Z).Value) = "ordered" Then
xRg(Z).EntireRow.Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
xRg(Z).EntireRow.Delete
If CStr(xRg(Z).Value) = "ordered" Then
Z = Z - 1
End If
Y = Y + 1
End If
Next
Application.ScreenUpdating = True
End Sub
There's probably a more elegant way to do this, but you can replace
xRg(Z).EntireRow.Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
With
Range(xRg(Z).EntireRow.Cells(1, 1), xRg(Z).EntireRow.Cells(1, 10)).Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
I'm getting a mysterious 'End If without block If' error in my vba 2013 code. Any insight on what's going wrong?
I get the error with both 'End If's. If I comment them out, it throws a 424 error at me on the second line of either of the 'If' blocks.
Code (in ThisWorkbook):
Sub TryAgain()
Dim ran As Range
Dim strt As Range
Dim X As Long
Application.ScreenUpdating = False
Set strt = Sheet3.Range("A2")
Set ran = Sheet3.Range(strt, strt.End(xlDown))
n = 1
For Each blah In ran:
cause = blah.Offset(0, 11)
X = 0
c = 0
Do Until X = n:
citem = Sheet4.Cells(1, 1).Offset(X, 0)
If cause.Value = citem.Value Then:
citem.Offset(0, 1).Value = citem.Offset(0, 1).Value + 1
c = c + 1
End If
X = X + 1
Loop
If c = 0 Then:
bernerner = Sheet4.Cells(1, 1).Offset(X, 0)
bernerner.Offset(1, 0).Value = cause.Value
bernerner.Offset(1, 1).Value = bernerner.Offset(1, 1).Value + 1
n = n + 1
End If
Next blah
Application.ScreenUpdating = True
End Sub
I don't think you need : in VBA.
For , While and If none of these need a : at the end.
I'm having trouble with a Runtime Error 13 "Type mismatch error". I am trying to take multiple lines of code and condense them into one line that is each row placed side by side. The problem is that my inputs are strings and numbers, which is what I believe is causing this problem. How can I fix this?
Sub multRowsTo1Row()
Dim inputRange As Variant
Dim outputRange As Variant
inputRange = Selection
y = UBound(inputRange, 1)
x = UBound(inputRange, 2)
ReDim outputRange(1 To x * y)
For j = 1 To y
For i = 1 To x
outputRange(i + y(j - 1)) = inputRange(j, i)
Next i
Next j
Selection.Offset(0, x).Select
End Sub
Declare your variables Dim x#, y# correctly. That will fix your Mismatch error, but will present you with another error, since y(j - 1) expects an array. Add the multiplication sign so that it is y * (j-1) and you will avoid that error, but you may get an overflow in the event that Selection.Rows.Count > 2, so you might also want to add a check for that.
Sub multRowsTo1Row()
Dim inputRange As Variant
Dim outputRange As Variant
Dim y#, x#
If selection.Rows.Count > 2 Then
MsgBox "Invalid Selection!", vbCritical
Exit Sub
End If
inputRange = Selection
y = UBound(inputRange, 1)
x = UBound(inputRange, 2)
ReDim outputRange(1 To x * y)
For j = 1 To y
For i = 1 To x
outputRange(i + y * (j - 1)) = inputRange(j, i)
Next i
Next j
Selection.Offset(0, x).Select
End Sub
As always, much pain & troubleshooting can be avoided with use of Option Explicit and also dimensioning your variables to a specific Type :)
I was successful thanks to David. Here's my finalized code.
Sub multRowsTo1Row()
'' This takes a multiple line array and places each row side by side
'' Currently places it next to the top row. This can be changed.
Dim inputRange As Variant
Dim outputRange As Variant
Dim x#, y#
inputRange = Selection
y = UBound(inputRange, 1)
x = UBound(inputRange, 2)
ReDim outputRange(1 To x * y)
For j = 1 To y
For i = 1 To x
outputRange(i + x * (j - 1)) = inputRange(j, i)
Next i
Next j
''Change this if you want to output somewhere else. This pastes the output to the right side of the last entry in the first row.
Selection.Offset(0, x).Resize(1, x * y).Select
Selection = outputRange
End Sub