The thing I am trying to do is if vInputs(1, i) is less than 22 I want the code to go to the next iteration column and if it's greater than 22 to just continue with the code.
The problem is in the If vInputs(1, i)... line. Not sure what I am doing wrong:
Sub CreateTestResultTableV2()
Application.ScreenUpdating = False 'helps the code run faster
Dim vInputs, vResults()
Dim c As Integer, i As Integer
'create INPUTS array
c = Range("b5").End(xlToRight).Column
vInputs = Range("b5", Cells(8, c))
'determine last value in the column
c = UBound(vInputs, 2)
'create RESULTS array
ReDim vResults(1 To 3, 1 To c)
For i = 1 To c
If vInputs(1, i) <= 22 Then GoTo Next i
Else
'set values
Range("j16") = vInputs(1, i)
Range("n12") = vInputs(4, i)
'copy output values into RESULTS array
vResults(1, i) = Range("h41")
vResults(2, i) = Range("k41")
vResults(3, i) = Range("z14")
Next i
Range("e47").Resize(3, c) = vResults
Application.ScreenUpdating = True
End Sub
Don't use a Goto statement to skip iterations in a loop. use the opposite operator and only execute the code in the loop when the conditions are True.
For i = 1 To c
If vInputs(1, i) > 22 Then
'set values
Range("j16") = vInputs(1, i)
Range("n12") = vInputs(4, i)
'copy output values into RESULTS array
vResults(1, i) = Range("h41")
vResults(2, i) = Range("k41")
vResults(3, i) = Range("z14")
End if
Next i
Related
I have 6 cells A1 to F1 (Shown below) in excel
How to concatenate all six cells but my cells with numbers should be subscript. Finally, I should get something like below for each row.
It is a lot of work to do subscript on each and every cell.
Previously I found a VBA code to combine two cells (Concatenation of 2 strings and superscript).
Option Explicit
Sub test()
Call SubscriptIt(Range("A1:H9"))
End Sub
Sub SubscriptIt(rng As Range)
Dim row As Range, cell As Range
Dim col As New Collection, v, ar
Dim i As Integer, s As String
For Each row In rng.Rows
Set col = Nothing
s = ""
' determine position,length of numbers
For Each cell In row.Cells
If IsNumeric(cell) Then
col.Add Len(s) & ":" & Len(cell)
End If
s = s & cell
Next
' output in next column
Set cell = row.Cells(1, rng.Columns.Count + 1)
cell = s
cell.Font.Subscript = False
' apply formatting
For Each v In col
ar = Split(v, ":")
cell.Characters(ar(0) + 1, ar(1)).Font.Subscript = True
Next
Next
MsgBox rng.Rows.Count & " rows updated"
End Sub
Please try this code. It presumes that your 6 cells start in column A and inserts the result in column G.
Sub CombineAndFormat()
' 212
Dim Fun As String ' output string
Dim Arr As Variant ' one row's data
Dim Chars() As Integer ' element length
Dim n As Integer ' character count
Dim i As Long ' loop counter: index
Dim R As Long ' loop counter: rows
Application.ScreenUpdating = False ' speeds up execution
With Worksheets("Sheet1") ' change to suit
' loop through rows 2 to end of column A
For R = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
Arr = .Range(.Cells(R, 1), .Cells(R, 6)).Value
ReDim Chars(1 To UBound(Arr, 2))
Fun = ""
n = 0
For i = 1 To UBound(Arr, 2)
Chars(i) = Len(Arr(1, i))
Fun = Fun & CStr(Arr(1, i))
Next i
With .Cells(R, 7)
.Value = Fun
With .Font ' this is the base font
' .Name = "Calibri" ' specify to suit
' .FontStyle = "Regular"
.Size = 11
.Subscript = False
End With
For i = 1 To 6 Step 2
With .Characters(Start:=n + Chars(i) + 1, Length:=Chars(i + 1)).Font
' this is the subscripted font:-
' .Name = "Calibri" ' specify to suit
' .FontStyle = "Regular"
.Subscript = True
End With
n = n + Chars(i) + Chars(i + 1)
Next i
End With
Next R
End With
Application.ScreenUpdating = True
End Sub
Function Subscript()
'Define Variables
Dim A, B, C, D, E, F As String
Dim l_A, l_B, l_C, l_D, l_E, l_F As Integer
'Read the content of the cells in row 2
A = Worksheets("Sheet14").Cells(2, 1).Value
B = Worksheets("Sheet14").Cells(2, 2).Value
C = Worksheets("Sheet14").Cells(2, 3).Value
D = Worksheets("Sheet14").Cells(2, 4).Value
E = Worksheets("Sheet14").Cells(2, 5).Value
F = Worksheets("Sheet14").Cells(2, 6).Value
'Get the length of each string in the second row
l_A = Len(A)
l_B = Len(B)
l_C = Len(C)
l_D = Len(D)
l_E = Len(E)
l_F = Len(F)
'Write the content of all cells together in the second row in the column G
Worksheets("Sheet14").Cells(2, 7).Value = A & B & C & D & E & F
'Write the content of Cell B as Subscript in Column G
Worksheets("Sheet14").Cells(2, 7).Characters(l_A + 1, l_B).Font.Subscript = True
'Write the content of Cell D as Subscript in Column G
Worksheets("Sheet14").Cells(2, 7).Characters(l_A + l_B + l_C + 1, l_D).Font.Subscript = True
'Write the content of Cell F as Subscript in Column G
Worksheets("Sheet14").Cells(2, 7).Characters(l_A + l_B + l_C + l_D + l_E + 1, l_F).Font.Subscript = True
End Function
I'm trying to clean up raw data exported from an online database.
There can be up to five columns. If all cells in a row have a value of 0, I want to delete that row.
When the user exports the data, they can choose to exclude columns, and the columns can be in any order.
For example, if the data contains only two of the possible five columns, I want to check just those two for 0s.
Could do a a big loop looking at every row and seeing if all 5 columns in that row are blank
Sub test()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("sheetname")
Dim LastRow As Integer
LastRow = sh.UsedRange.Rows.Count - 1
For i = 1 To LastRow
If (sh.Cells(i, 1).Value = "" And sh.Cells(i, 2).Value = "" And sh.Cells(i, 3).Value = "" And _
sh.Cells(i, 4).Value = "" And sh.Cells(i, 5).Value = "") Then
sh.Cells(i, 1).EntireRow.Delete
i = i - 1
Dim newLastRow As Integer
newLastRow = sh.UsedRange.Rows.Count - 1
If i = newLastRow Then
Exit For
End If
End If
Next i
MsgBox ("Done")
End Sub
#kyle campbell, thank you for your input! It didn't quite get me there, but it did get my wheels turning. Here is the solution I came up with, if anyone's curious:
I set a variable to represent the column number for each of the 5 possible columns using Range.Find. If the Find came up with nothing, I set the variable to 49, since the maximum number of columns this report can have is 48.
Then I did a nested If to test if the value in each cell was either 0 or null (because if the column number is 49, there won't be any data there). If all Ifs were true, I deleted the row. I also added a counter and message box, just to make sure this worked.
Sub DeleteRows()
Dim O As Long
Dim E As Long
Dim H As Long
Dim B As Long
Dim P As Long
lRow = Range("A1").CurrentRegion.Rows.Count
If Range("1:1").Find("SUM(OBLIGATIONS)") Is Nothing Then
O = 49
Else
O = Range("1:1").Find("SUM(OBLIGATIONS)").Column
End If
If Range("1:1").Find("SUM(EXPENDITURES)") Is Nothing Then
E = 49
Else
E = Range("1:1").Find("SUM(EXPENDITURES)").Column
End If
If Range("1:1").Find("SUM(HOURS)") Is Nothing Then
H = 49
Else
H = Range("1:1").Find("SUM(HOURS)").Column
End If
If Range("1:1").Find("SUM(BUDGET_RESOURCES)") Is Nothing Then
B = 49
Else
B = Range("1:1").Find("SUM(BUDGET_RESOURCES)").Column
End If
If Range("1:1").Find("SUM(PRIOR_YEAR_RECOVERY)") Is Nothing Then
P = 49
Else
P = Range("1:1").Find("SUM(PRIOR_YEAR_RECOVERY)").Column
End If
Dim j As Integer
j = 0
For i = lRow To 2 Step -1
If Cells(i, O) = 0 Or Cells(i, O) = "" Then
If Cells(i, E) = 0 Or Cells(i, E) = "" Then
If Cells(i, H) = 0 Or Cells(i, H) = "" Then
If Cells(i, B) = 0 Or Cells(i, B) = "" Then
If Cells(i, P) = 0 Or Cells(i, P) = "" Then
Rows(i).Delete
j = j + 1
End If
End If
End If
End If
End If
Next i
MsgBox "Macro complete, " & j & " lines deleted."
End Sub
I have a column with certain values which are also the headers for some columns. I want to check where the column values match and paste the value from the first column into the column with the same column name. I have around 1200 values in the first column. I want to loop through those values and paste the matching values in the corresponding row.
[![Data][1]][1]
Here is my sheet with my data that I want to work on. How I want my final sheet to look like is as follows:
Weeks | W1 | W2 | W3 | W4 | W5 | W6
W1 W1
W3 W3
Any help for the same would be highly appreciated.
Sub Weeks()
Application.ScreenUpdating = False
Dim i As Long, j As Long, Mas As Worksheet
Set Mas = Sheets("Master Sheet")
For i = 5 To 1200
If Mas.Range("B" & i) <> "" Then
If Mas.Range("AO" & i) = "Missing week" Then
Mas.Range("AV" & i) = ""
Mas.Range("AW" & i) = ""
Mas.Range("AX" & i) = ""
Mas.Range("AY" & i) = ""
Mas.Range("AZ" & i) = ""
Mas.Range("BA" & i) = ""
Else
For j = 5 To 1200
If Mas.Range("AO" & i) = "W1" Then
Mas.Range("AV" & j) = "W1"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W2" Then
Mas.Range("AW" & j) = "W2"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W3" Then
Mas.Range("AX" & j) = "W3"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W4" Then
Mas.Range("AY" & j) = "W4"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W5" Then
Mas.Range("AZ" & j) = "W5"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W6" Then
Mas.Range("BA" & j) = "W6"
GoTo Nexti
End If
Next j
End If
End If
Nexti:
Next i
End Sub
This is the code I tried so far but it does not show any output.
This is how you use the dictionary to achieve your goal:
Option Explicit
Sub Weeks()
Dim Mas As Worksheet: Set Mas = ThisWorkbook.Sheets("Master Sheet")
With Mas
'Calculate thelast row
Dim i As Long
Dim LastRow As Long: LastRow .Cells(.Rows.Count, "AO").End(xlUp).Row
'insert your data into an array
Dim arr As Variant: arr = .Range("AO5:BA" & LastRow).Value
'Generate a dictionary with the headers
'this needs the library Microsoft Scripting Runtime under Tools->References
Dim Headers As Dictionary: Set Headers = LoadHeaders(.Range("AO4:BA4").Value)
'Now loop through the array
For i = 1 To UBound(arr)
If Headers.Exists(arr(i, 1)) Then arr(i, Headers(arr(i, 1))) = arr(i, 1)
arr(i, 1) = vbNullString
Next i
.Range("AO5:BA" & LastRow).Value = arr
End With
End Sub
Private Function LoadHeaders(arr As Variant) As Dictionary
Set LoadHeaders = New Dictionary
Dim i As Long
For i = 1 To UBound(arr, 2)
LoadHeaders.Add arr(1, i), i
Next i
End Function
You won't even need the Application.ScreenUpdating because it does only one operation in Excel, will take a second or two to end this procedure.
Place this code in a module and link it to a button on the sheet.
'data
Cells.Clear
wks = Array("W1", "W2", "W3", "W4", "W5", "W6", "Missing week")
For i = 1 To 30
Cells(i, 2) = wks(Int(Rnd * 7))
Next i
'code
Set weeks = [b:b]
For Each wk In weeks
If Len(wk) = 2 Then Cells(wk.Row, Right(wk, 1) + 2) = wk
Next wk
weeks contains the column that has the list of column headings. The For..Each statement loops through each entry in this list.
Then it checks each entries string length. If it is length 2, it assumes the entry is valid (i.e of the form 'Wx' with x between 1 and 6), and then uses the inbuilt Right function to find the value of x, and then adds the appropriate entry into the appropriate column.
In the worksheet called "EIRP LL", Range L6:O13 contains data. Sometimes, rows 7-13 get hidden for reasons unrelated to this data. The data in Range L6:O13 shall remain unhidden, so the data in L6:O13 is copied into an array called ConfigDataArray. Range L6:O13 is then cleared. All of this code works.
Then, the difficulty begins. The data that is stored in ConfigDataArray must be written to the non-hidden rows beginning with Row 6, which happens to always be unhidden. I have attempted to do this by slicing the rows of the array and iterating through these rows with a For loop. But it doesn't work. Only the 1st and 3rd rows of the array data get written back into the worksheet, and the third row gets written into a hidden row. The code beginning with j = 6 and ending with Next, clearly is faulty. Any suggestions greatly appreciated.
Sub HideLLRows()
'Hide blank rows in EIRP LL
'Where blank row is defined as no data in Col B for the given row
Application.ScreenUpdating = False
Dim ConfigDataArray As Variant
Set EIRPLL = Sheets("EIRP LL")
LastLLRow = EIRPLL.UsedRange.Rows.Count
'Put the metadata into an 8Row x 4Col array for safe keeping
ConfigDataArray = Range("L6:O13").Value
'Clear the metadata cells
Range("L6:O13").Clear
'Hide the blank rows
For i = 6 To LastLLRow
If EIRPLL.Range("B" & i) = "" Then
EIRPLL.Rows(i).Hidden = Not EIRPLL.Rows(i).Hidden
End If
Next
'Slice the 8 array rows and put into the first 8 non-hidden rows
'beginning on L6:O6 (which is always non-hidden)
j = 6
For k = 1 To 8
If Rows(j).Hidden = False Then
If k < 9 Then
EIRPLL.Range("L" & k + 5) = Application.Index(ConfigDataArray, k, 1)
EIRPLL.Range("M" & k + 5) = Application.Index(ConfigDataArray, k, 2)
EIRPLL.Range("N" & k + 5) = Application.Index(ConfigDataArray, k, 3)
EIRPLL.Range("O" & k + 5) = Application.Index(ConfigDataArray, k, 4)
End If
End If
k = k + 1
j = j + 1
Next
Application.ScreenUpdating = True
End Sub
Sub HideLLRows()
Dim ConfigDataArray As Variant, i, k, j
Dim EIRPLL As Worksheet, LastLLRow
Set EIRPLL = Sheets("EIRP LL")
LastLLRow = EIRPLL.UsedRange.Rows.Count
Application.ScreenUpdating = False
'Clear the metadata cells
With EIRPLL.Range("L6:O13")
ConfigDataArray = .Value
.Clear
End With
'Hide the blank rows
For i = 6 To LastLLRow
If EIRPLL.Range("B" & i) = "" Then
EIRPLL.Rows(i).Hidden = True
End If
Next
k = 1
j = 6
Do While k <= 8
With EIRPLL.Rows(j)
If Not .Hidden Then
.Cells(12).Value = ConfigDataArray(k, 1)
.Cells(13).Value = ConfigDataArray(k, 2)
.Cells(14).Value = ConfigDataArray(k, 3)
.Cells(15).Value = ConfigDataArray(k, 4)
k = k + 1
End If
End With
j = j + 1
Loop
Application.ScreenUpdating = True
End Sub
i have 2 sheets , i want to find the same rows in 2 sheets , so i put the first row in array , and by a for next i define the first array ...then i define another array from second sheet , then i compare them .... why it doesn't work?
Sub compare()
Dim n(4) As Variant
Dim o(4) As Variant
Dim i As Integer
For i = 3 To 20 'satrha
For j = 2 To 4 'por kardan
n(j) = Sheets("guys").Cells(i, j)
Next 'por kardan
k = 3
Do 'hhhh
For Z = 2 To 4 'por dovomi
o(Z) = Sheets("p").Cells(k, Z)
Next 'por dovomi
If n(j) = o(Z) Then
Sheets("guys").Cells(i, 1) = Sheets("p").Cells(k, 2)
flag = True
Else
flag = False
k = k + 1
End If
Loop Until flag = False 'hhhhh
Next 'satrha
End Sub
Guessing from your existing code, my following code will copy the value from sheet "p" column B into sheet "guys" column A when a match is found.
Sub compare()
Dim i As Integer
Dim j As Integer
Dim l As Integer
l = Sheets("p").Range("B65535").End(xlUp).Row
Debug.Print l
For i = 3 To 20
For j = 3 To l
If Sheets("guys").Cells(i, 2).Value = Sheets("p").Cells(j, 2).Value And _
Sheets("guys").Cells(i, 3).Value = Sheets("p").Cells(j, 3).Value And _
Sheets("guys").Cells(i, 4).Value = Sheets("p").Cells(j, 4).Value Then
Sheets("guys").Cells(i, 1).Value = Sheets("p").Cells(j, 2).Value
Exit For
End If
Next
Next
End Sub
Noted that I explicitly said Value in my code. That will copy the computed value (e.g. result of a formula) instead of the "original" content.