VBA nested looping with do until loop - vba

I need a looping structure that checks a range of cells, then if the cell and a cell that is in the range equal each other then the font should turn red. My problem is that my do until loop won't get entered. This is what I have right now.
`
Dim finalrow As Long
finalrow = Worksheets("Redundancy").Cells(Worksheets("Redundancy").Rows.Count, "D").End(xlUp).Row
Dim z As Long
Dim w As Long
Dim r As Long
w = 2
r = 0
For z = 2 To finalrow
If Range("L" & z) = Range("L" & z + 1) & Range("J" & z) <> Range("J" & z + 1) Then
Do Until Range("L" & z) = Range("L" & z + 1) & Range("J" & z) <> Range("J" & z + 1)
If Cells(w, 4) = Cells(z + 1, 4 + r) Then
Cells(w, 1).Font.ColorIndex = 3
Cells(z + 1, 1).Font.ColorIndex = 3
If r = 4 Then
w = w + 1
End If
End If
r = r + 1
Loop
End If
Next z
`
I changed it to this, but it exits the loop all together right when it is about to enter the do while loop.
`
For z = 2 To finalrow
Do While (Range("L" & z) = Range("L" & z + 1) And Range("J" & z) <> Range("J" & z + 1))
If Cells(w, 4) = Cells(z + 1, 4 + r) Then
Cells(w, 1).Font.ColorIndex = 3
Cells(z + 1, 1).Font.ColorIndex = 3
If r = 4 Then
w = w + 1
End If
End If
r = r + 1
Loop
Next z
`

If you do this;
Range("L" & z) = Range("L" & z + 1) and Range("J" & z) <> Range("J" & z + 1)
you are comparing Range objects. What you instead want to do is to compare the values in those range objects. So use this instead;
Range("L" & z).value = Range("L" & z + 1).value and Range("J" & z).value <> Range("J" & z + 1).value
However when you use the cells(row,column) you don't have this problem.
I am curious though, was it not possible to use conditional formatting instead?

Use the 'and' operator instead of '&'.

Related

How to copy from column to row not using PasteSpecial Transpose?

This loop to copies the values from one sheet's columns to another sheet's columns:
Dim ExposureDataInput As Worksheet
Dim ManualSimulation As Worksheet
Set EDI = Sheets("ExposureDataInput")
Set MS = Sheets("ManualSimulation")
Dim i As Integer
Dim n As Integer
For i = 2 To EDI.Range("B" & Rows.Count).End(xlUp).Row
If EDI.Range("B" & i).Value > 0 Then
n = MS.Range("A" & Rows.Count).End(xlUp).Row + 1
MS.Range("A" & n).Value = EDI.Cells(i, 1).Value
n = MS.Range("B" & Rows.Count).End(xlUp).Row + 1
MS.Range("B" & n).Value = EDI.Cells(i, 2).Value
n = MS.Range("C" & Rows.Count).End(xlUp).Row + 1
MS.Range("C" & n).Value = EDI.Cells(i, 4).Value
n = MS.Range("D" & Rows.Count).End(xlUp).Row + 1
MS.Range("D" & n).Value = EDI.Cells(i, 6).Value
n = MS.Range("E" & Rows.Count).End(xlUp).Row + 1
MS.Range("E" & n).Value = EDI.Cells(i, 8).Value
n = MS.Range("F" & Rows.Count).End(xlUp).Row + 1
MS.Range("F" & n).Value = EDI.Cells(i, 10).Value
n = MS.Range("G" & Rows.Count).End(xlUp).Row + 1
MS.Range("G" & n).Value = EDI.Cells(i, 12).Value
End If
Next i
I tried the same principal to get the col A:A from one sheet to a row in another sheet:
Dim ExposureDataInput As Worksheet
Dim HistoricalDataandExcessReturns As Worksheet
Set EDI = Sheets("ExposureDataInput")
Set HDaER = ThisWorkbook.Worksheets("HistoricalDataandExcessReturns")
Dim k As Integer
Dim y As Integer
For k = 2 To EDI.Range("B" & Rows.Count).End(xlUp).Row
If EDI.Range("B" & k).Value > 0 Then
y = HDaER.Range(Columns.Count & 1).End(xlToLeft).Column + 1
HDaER.Range(y & 1).Value = EDI.Cells(1, k).Value
y = HDaER.Range(Columns.Count & 2).End(xlToLeft).Column + 1
HDaER.Range(y & 2).Value = EDI.Cells(2, k).Value
End If
Next k
The i in the column to column works. When I try with k in a column to row it gives me
Run-time error '1004'.
How can I copy a column to a row?
I believe the issue lies with the way you are trying to get the last Column, please have a look at my answer below:
The first sub could be written as:
Dim ExposureDataInput As Worksheet
Dim ManualSimulation As Worksheet
Set EDI = Sheets("ExposureDataInput")
Set MS = Sheets("ManualSimulation")
Dim i As Long
Dim n As Long
For i = 2 To EDI.Range("B" & EDI.Rows.Count).End(xlUp).Row
If EDI.Range("B" & i).Value > 0 Then
n = MS.Cells(MS.Rows.Count, "A").End(xlUp).Row + 1
'get the next free row without data on Column A
MS.Range("A" & n).Value = EDI.Cells(i, 1).Value
MS.Range("B" & n).Value = EDI.Cells(i, 2).Value
MS.Range("C" & n).Value = EDI.Cells(i, 4).Value
MS.Range("D" & n).Value = EDI.Cells(i, 6).Value
MS.Range("E" & n).Value = EDI.Cells(i, 8).Value
MS.Range("F" & n).Value = EDI.Cells(i, 10).Value
MS.Range("G" & n).Value = EDI.Cells(i, 12).Value
End If
Next i
The second sub could be written as:
Dim ExposureDataInput As Worksheet
Dim HistoricalDataandExcessReturns As Worksheet
Set EDI = Sheets("ExposureDataInput")
Set HDaER = ThisWorkbook.Worksheets("HistoricalDataandExcessReturns")
Dim k As Long
Dim y As Long
For k = 1 To EDI.Cells(EDI.Rows.Count, "B").End(xlUp).Row
If EDI.Range("B" & k).Value > 0 Then
y = HDaER.Cells(1, HDaER.Columns.Count).End(xlToLeft).Column + 1
'count the number of column on row 1
HDaER.Cells(1, y).Value = EDI.Cells(k, 1).Value
y = HDaER.Cells(2, HDaER.Columns.Count).End(xlToLeft).Column + 1
'count the number of columns on row 2?
HDaER.Cells(2, y).Value = EDI.Cells(k, 2).Value
End If
Next k
Actually, the error you should be getting is 6 - Overflow.
Try this small piece of code:
Sub TestMe()
Dim a As Integer
a = Rows.Count
End Sub
You would get an overflow error, because the Integer is from -32768 to 32767 and the rows in Excel are more than 1 million. The columns are 16384, thus they enough for an integer.
Replace the Integer with Long and try again.

Excel VBA To Concatenate

from some googling I found this function that will concatenate the data in columns A, B & C based off the value in column D. This code does not work for me for some reason. My data looks like such
Bob Jason 0123456789 Tim
Jim Jason 0123456789 Tim
Fred Jason 0123456789 Tim
Columns, A and B concat fine, but column C concats to
12,345,678,901,234,500,000,000,000,000
How would the VBA be altered so that the code will concatenate properly?
Sub Concat()
Dim x, i As Long, ii As Long
With Cells(1).CurrentRegion
x = .Columns("d").Offset(1).Address
x = Filter(Evaluate("transpose(if(countif(offset(" & x & ",,,row(1:" & .Rows.Count & "))," & x & ")=1," & x & "))"), False, 0)
For i = 0 To UBound(x)
For ii = 1 To 3
Cells(i + 2, ii + 5).Value = Join(Filter(Evaluate("transpose(if(" & .Columns(4).Address & "=""" & _
x(i) & """," & .Columns(ii).Address & "))"), False, 0), ",")
Next
Cells(i + 2, ii + 5).Value = x(i)
Next
End With
End Sub
You need to set the destination cells to a Text format:
Sub Concat()
Dim x, i As Long, ii As Long
With Cells(1).CurrentRegion
x = .Columns("d").Offset(1).Address
x = Filter(Evaluate("transpose(if(countif(offset(" & x & ",,,row(1:" & .Rows.Count & "))," & x & ")=1," & x & "))"), False, 0)
For i = 0 To UBound(x)
For ii = 1 To 3
Cells(i + 2, ii + 5).NumberFormat = "#"
Cells(i + 2, ii + 5).Value = Join(Filter(Evaluate("transpose(if(" & .Columns(4).Address & "=""" & _
x(i) & """," & .Columns(ii).Address & "))"), False, 0), ",")
Next
Cells(i + 2, ii + 5).NumberFormat = "#"
Cells(i + 2, ii + 5).Value = x(i)
Next
End With
End Sub

Counting the columns in sheet1 and pasting their result in a table in sheet 2

I have two sheets. sheet1 is Evaluation and sheet2 is the result sheet.
From the Evaluation sheet1, I would like to count the number of "OK" in Column S and T and count the number of "Invalid" in the column R.
These counted values are to be entered In the sheet2 result , in their corresponding columns.
I was working with this code and It worked completely fine.
But now, when I run the code, number of OK in the column S and T and number of Invalid in the column R are not counted.
Here is the Code I am trying to work with
Sub result()
Dim i As Integer
Dim j As Integer
Dim cnt As Integer
Dim cntU, CntS, cntT As Integer
Dim sht As Worksheet
Dim totalrows, n As Long
Set sht = Sheets("Result")
Sheets("Evaluation").Select
totalrows = Range("A5").End(xlDown).Row
n = Worksheets("FC_SCR Evaluation").Range("A5:A" & totalrows).Cells.SpecialCells(xlCellTypeConstants).count
For i = 2 To WorksheetFunction.count(sht.Columns(1))
cntT = 0
cntU = 0
CntS = 0
' get the current week of column A of result sheet
If sht.Range("A" & i) = Val(Format(Now, "WW")) Then Exit For
Next i
' if column A of result sheet and Column x of fc sheet are same, then count the mentioned parameters
For j = 5 To WorksheetFunction.CountA(Columns(23))
If sht.Range("A" & i) = Range("X" & j) And Range("T" & j) = "OK" Then cntT = cntT + 1
If sht.Range("A" & i) = Range("X" & j) And Range("S" & j) = "OK" Then cntU = cntU + 1
If sht.Range("A" & i) = Range("X" & j) And Range("R" & j) = "Invalid" Then CntS = CntS + 1
' print the counted value in corresponding column of result sheet
If cntT <> 0 Then sht.Range("D" & i) = cntT
If cntU <> 0 Then sht.Range("E" & i) = cntU
If CntS <> 0 Then sht.Range("C" & i) = CntS
If n <> 0 Then sht.Range("B" & i) = n
Next j
If cntT + cntU <> 0 Then
sht.Range("F" & i) = CntS / n
sht.Range("g" & i) = cntT / n
sht.Range("h" & i) = cntU / n
End If
End Sub

Excel VBA Screenupdating False Infinite Loop

I have a function that maps data from one sheet (where it has been copied) to another which is then used for further analysis. When I run the code with screen updating on it always works fine. When I turn screen updating off the code gets stuck in an infinite loop in the last part of the sub (highlighted in bold - it is the inner most loop of the final section of code). If you then debug the code and re-start it continues normally and finished the code. If left it will never end, but next time will work fine:
Sub simsMap()
Dim simsCol As String
Dim mapCol As String
range("A5:OP253").ClearContents
range("S1:OP1").ClearContents
range("S4:OP4").ClearContents
simsCol = range("A1")
For x = 2 To 250
If Worksheets("simsData").range(simsCol & x) <> "" Then range("A" & x + 3).Value = Worksheets("simsData").range(simsCol & x)
Next x
simsCol = range("B1")
For x = 2 To 250
If range("A" & x + 3) <> "" Then
If Worksheets("simsData").range(simsCol & x) = range("B2") Or Worksheets("simsData").range(simsCol & x) = range("B3") Then
range(simsCol & x + 3) = "Y"
Else
range(simsCol & x + 3) = "N"
End If
End If
Next x
Dim simsArray As Variant
Dim mapArray As Variant
simsArray = Array("C1", "D1", "G1")
mapArray = Array("C", "D", "G")
For y = 0 To UBound(simsArray)
simsCol = range(simsArray(y))
mapCol = mapArray(y)
For x = 2 To 250
If range("A" & x + 3) <> "" Then
If Worksheets("simsData").range(simsCol & x) = "Y" Then
range(mapCol & x + 3) = "Y"
Else
range(mapCol & x + 3) = "N"
End If
End If
Next x
Next y
simsArray = Array("E1", "F1", "H1", "I1", "J1", "K1", "L1", "M1", "N1", "O1", "P1", "Q1")
mapArray = Array("E", "F", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q")
For y = 0 To UBound(simsArray)
simsCol = range(simsArray(y))
mapCol = mapArray(y)
For x = 2 To 250
If range("A" & x + 3) <> "" Then
range(mapCol & x + 3) = Worksheets("simsData").range(simsCol & x)
End If
Next x
Next y
Dim realColumn As String
Dim valueColumn As String
Dim columnNumber As Long
Dim realCell As String
Dim valueCell As String
Dim subjectJump As Integer
realColumn = "S"
subjectJump = 8 - Worksheets("menu").range("F17")
For y = 1 To 48
If Worksheets("menu").range("F19") = "Y" Then
valueColumn = range(realColumn & 1)
realCell = realColumn & 1
realColumn = Split(Cells(1, range(realCell).Column + 1).Address, "$")(1)
range(realColumn & 1) = valueColumn
For x = 1 To Worksheets("menu").range("F17")
valueCell = range(realColumn & 1) & 1
If range(realColumn & 1) <> "" Then valueColumn = Split(Cells(1, range(valueCell).Column + 1).Address, "$")(1)
realCell = realColumn & 1
realColumn = Split(Cells(1, range(realCell).Column + 1).Address, "$")(1)
range(realColumn & 1) = valueColumn
Next x
Else
If range(realColumn & 1) = "" Then
realCell = realColumn & 1
realColumn = Split(Cells(1, range(realCell).Column + 8).Address, "$")(1)
Else
For x = 1 To Worksheets("menu").range("F17")
valueCell = range(realColumn & 1) & 1
valueColumn = Split(Cells(1, range(valueCell).Column + 1).Address, "$")(1)
realCell = realColumn & 1
realColumn = Split(Cells(1, range(realCell).Column + 1).Address, "$")(1)
range(realColumn & 1) = valueColumn
Next x
realCell = realColumn & 1
realColumn = Split(Cells(1, range(realCell).Column + subjectJump).Address, "$")(1)
End If
End If
Next y
realColumn = "S"
For y = 1 To 384
simsCol = range(realColumn & 1)
mapCol = realColumn
If range(mapCol & 1) <> "" Then
If range("A" & 4) <> "" Then
range(mapCol & 4) = Worksheets("simsData").range(simsCol & 1)
End If
End If
realColumn = Split(Cells(1, range(realColumn & 1).Column + 1).Address, "$")(1)
Next y
realColumn = "S"
For y = 1 To 384
simsCol = range(realColumn & 1)
mapCol = realColumn
If range(mapCol & 1) <> "" Then
For x = 2 To 250
**If range("A" & x + 3) <> "" Then
range(mapCol & x + 3) = Left(Worksheets("simsData").range(simsCol & x), 1)
End If**
Next x
End If
realColumn = Split(Cells(1, range(realColumn & 1).Column + 1).Address, "$")(1)
If y = 384 Then loopCheck = False
Next y
For x = 5 To 253
If range("A" & x) <> "" Then studentNumber = x
Next x
End Sub

Using Month function in VBA

I have two sheets, sheet1 is the report, and sheet2 is the result. In the result sheet I have in column A the months represented as "Jan", "Feb", etc and so on. In my report sheet I have the months represented in number.
My requirement is , to check the column W of report sheet is same as Column A of the result sheet. If they are same, then I have to print the count result in result sheet.
I have the below code to return the month
Sub month()
Dim ws As Worksheet
Dim i As Long
Dim totalrows As Long
Set ws = Sheets("Report")
totalrows = ws.Cells(Rows.count, "A").End(xlUp).Row
MsgBox (totalrows & " Check")
For i = 5 To totalrows
' get the current week in column 23
Cells(i, 23).Value = Month(Now)
Next
End Sub
the below code, checks for the current month in both the sheets and prints the count value . could someone help, how I can say the VBA that the Column W containing 9 is same as Column A containing September. ? The month entered in the column A is manual entry.
Sub result()
Dim i As Long, j As Long, cntR As Long, CntS As Long, cntT As Long, cntU As Long, sht As Worksheet
Set sht = Sheets("Result")
Sheets("Report").Select
For i = 2 To WorksheetFunction.CountA(sht.Columns(1))
' get the current week from column A of the sheet result
If sht.Range("A" & i) = Val(Month(Now)) Then Exit For
Next i
sht.Range("C" & i & ":" & "J" & i).ClearContents
For j = 5 To WorksheetFunction.CountA(Columns("W"))
' if column A and column W are same, then count 1, in column A, R; S, T, U
If sht.Range("A" & i) = Range("W" & j) Then
If Range("R" & j) = "1" Then cntR = cntR + 1
If Range("S" & j) = "1" Then CntS = CntS + 1
If Range("T" & j) = "1" Then cntT = cntT + 1
If Range("U" & j) = "1" Then cntU = cntU + 1
End If
Next j
' print the count values in the respective column
If cntR <> 0 Then sht.Range("C" & i) = cntR
If CntS <> 0 Then sht.Range("D" & i) = CntS
If cntT <> 0 Then sht.Range("E" & i) = cntT
If cntU <> 0 Then sht.Range("F" & i) = cntU
If cntR + CntS + cntT + cntU <> 0 Then
sht.Range("G" & i) = cntR / (cntR + CntS + cntT + cntU)
sht.Range("H" & i) = CntS / (cntR + CntS + cntT + cntU)
sht.Range("I" & i) = cntT / (cntR + CntS + cntT + cntU)
sht.Range("J" & i) = cntU / (cntR + CntS + cntT + cntU)
End If
End Sub