How can I implement if Sheet1 has row16 filled with anything it'll continue the function. If row16 is blank then skip function?
Initially I wanted row 2 to row15 from sheet1 to be copied into sheet2 and anything from row16 will be put on sheet3.
The code I have currently works fine with anything over 15 rows of data. But if it gets below 15 rows it gets buggy.
With Sheets("sheet1")
Set Rng = .Range("T2:T15")
End With
For i = 1 To Rng.Count * 2 Step 2
r = r + 1
Sheets("Sheet2").Range("C" & i + 13).Value = Rng(r).Value
Sheets("Sheet2").Range("D" & i + 14).Value = Rng(r).Value
Next i
With Sheets("sheet1")
Set Rng2 = .Range("T16", .Range("T" & Rows.Count).End(xlUp))
End With
For i2 = 1 To Rng2.Count * 2 Step 2
r2 = r2 + 1
Sheets("Sheet3").Range("C" & i2 + 7).Value = Rng2(r2).Value
Sheets("Sheet3").Range("D" & i2 + 8).Value = Rng2(r2).Value
Next i2
CountBlank vs CountA
Replace your second With block with the following one:
CountBlank
With Sheets("sheet1")
If Application.CountBlank(.Rows(16)) = .Columns.Count Then
Exit Sub
Else
Set Rng2 = .Range("T16", .Range("T" & Rows.Count).End(xlUp))
End If
End With
CountA
In this case, If Application.CountA(.Rows(16)) = 0 Then is unreliable because it will 'pick up' any cells containing formulas evaluating to "". Although sometimes you might need this behavior.
If you just want to check cell T16 do the following:
Len
With Sheets("sheet1")
If Len(.Range("T16").Value) = 0 Then
Exit Sub
Else
Set Rng2 = .Range("T16", .Range("T" & Rows.Count).End(xlUp))
End If
End With
Related
Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).
The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.
My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).
The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.
Can someone please tell me if there is a faster way to do this than to loop through each row?
Please let me know if you need more information. Thanks in advance.
Code:
Sub VerticalAnalysis()
Dim EmpID As Range
Dim i As Long
Dim cell As Range
Dim lastrow As Range
Dim LastCol As Long
Dim curRow As Long
Dim c As Long
Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
Worksheets("Vertical").Select
Range("B3", "H" & Rows.Count).ClearContents
Range("B3", "H" & Rows.Count).ClearFormats
ThisWorkbook.Worksheets("Variance").Select
c = 1
For Each cell In EmpID
i = 2
Do Until i >= LastCol
cell.Offset(0, i).Select
If IsError(ActiveCell) Then
ElseIf ActiveCell <> "" Then
If IsNumeric(ActiveCell) = True Then
If ActiveCell <> 0 Then
cell.Copy
Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(-c, -2).Copy
Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -2).Copy
Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -1).Copy
Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
i = i + 4
Loop
c = c + 1
Next cell
ThisWorkbook.Worksheets("Vertical").Select
Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"
Application.ScreenUpdating = True
End Sub
You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)
https://analystcave.com/excel-using-sql-in-vba-on-excel-data/
Better not to hit the sheet so many times.
Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:
Sub VerticalAnalysis()
Const BLOCK_SIZE As Long = 30000
Dim lastrow As Long
Dim LastCol As Long
Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
Set wsVar = ThisWorkbook.Worksheets("Variance")
Set wsVert = ThisWorkbook.Worksheets("Vertical")
lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
'get all the input data as an array (including headers)
data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
'clear the output sheet and set up the "transfer" array
With wsVert.Range("B3", "H" & Rows.Count)
.ClearContents
.ClearFormats
End With
rwVert = 3 'first "vertical" result row
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4) 'for collecting matches
i = 0
n = 0
For r = 2 To UBound(data, 1) 'loop rows of input array
empId = data(r, 2) 'colB ?
c = 7 'first "difference" column ?
Do While c <= UBound(data, 2)
v = data(r, c)
If Not IsError(v) Then
If IsNumeric(v) Then
If v > 0.7 Then
i = i + 1
n = n + 1
dataVert(i, 1) = empId
dataVert(i, 2) = data(1, c) 'header
dataVert(i, 3) = data(r, c + 2) 'value1
dataVert(i, 4) = data(r, c + 1) 'value2
'have we filled the temporary "transfer" array?
If i = BLOCK_SIZE Then
wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
i = 0
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
rwVert = rwVert + BLOCK_SIZE
End If
End If
End If
End If
c = c + 4 'next difference
Loop
Next r
'add any remaining
If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
wsVert.Select
wsVert.Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"
End Sub
This part of my macro is for coloring the cells in row B, depending on their value and the value of the corresponding cell in row Q. It works well, but when the file is large (sometimes over 500,000 rows), this step can really slow down the entire execution of the macro. There is also the likelyhood that I will need to add more colors down the road, which will mean more IF statement lines which will slow it down even more.
Dim LastRow As Long
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim i As Long, r1 As Range, r2 As Range
For i = 11 To LastRow
Set r1 = Range("B" & i)
Set r2 = Range("Q" & i)
If r2 = "001111" Then r1.Interior.Color = vbGreen
If (r1 < 4 Or r1 > 0) And (r2 <> "001111") Then r1.Interior.Color = vbYellow
If (r1 > 3 Or r1 < 1) And (r2 <> "001111") Then r1.Interior.Color = vbRed
Next i
I tried using some code for conditional formatting on the entire row. This is much faster, but I wasn't able to figure out how to include the value of the cell in column Q as a condition. I was also limited to no more conditions than three.
Is there a way to accomplish this task in a way that is faster than my current code that will also allow for more conditions/colors in the future?
Scratch my previous attempt. I do agree that Range.AutoFilter might even be better:
Sub Test()
Dim lr As Long, rng As Range
With Sheet1
'Get last used row of data and set range
lr = .Cells(.Rows.Count, 2).End(xlUp).Row
Set rng = .Range("B10:Q" & lr)
'Apply first filter and color Green
rng.AutoFilter 16, "001111"
If rng.Columns(1).SpecialCells(12).Count > 1 Then rng.Columns(1).Offset(1).Resize(lr - 10).Interior.Color = vbGreen
'Apply second filter and color Yellow
rng.AutoFilter 16, "<>*001111*"
rng.AutoFilter 1, "<4", xlAnd, ">0"
If rng.Columns(1).SpecialCells(12).Count > 1 Then rng.Columns(1).Offset(1).Resize(lr - 10).Interior.Color = vbYellow
'Apply third filter and color Red
rng.AutoFilter 1, ">3", xlOr, "<1"
If rng.Columns(1).SpecialCells(12).Count > 1 Then rng.Columns(1).Offset(1).Resize(lr - 10).Interior.Color = vbRed
'Remove AutoFilter
rng.AutoFilter
End With
End Sub
I guess the fastest would be to use an array? Maaaaybe some filter but I'm just gonna do the array for now:
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Tabelle1").Range("B11:B500000") = 1
ThisWorkbook.Sheets("Tabelle1").Range("Q11:Q500000") = 2
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim r1
Dim r2
r1 = ThisWorkbook.Sheets("Tabelle1").Range("B11:B" & LastRow)
r2 = ThisWorkbook.Sheets("Tabelle1").Range("Q11:Q" & LastRow)
For i = LBound(r1) To UBound(r1)
If r2(i, 1) = "001111" Then r1(i, 1) = vbGreen
If (r1(i, 1) < 4 Or r1(i, 1) > 0) And (r2(i, 1) <> "001111") Then r1(i, 1) = vbYellow
If (r1(i, 1) > 3 Or r1(i, 1) < 1) And (r2(i, 1) <> "001111") Then r1(i, 1) = vbRed
Next i
With ThisWorkbook.Sheets("Tabelle1")
For i = LBound(r1) To UBound(r1)
.Range("B" & 10 + i).Interior.Color = r1(i, 1)
Next
End With
Application.ScreenUpdating = True
I wish we could apply the .Interior.Color all in one go but I can't get that to work. If someone else does, I'd really like to know too! This executes in 24.75s on my machine. Oh and I didn't check your logic for the <, > things, I just added an array. It will likely break if something unexpected is written in one of the cells, like a string or something.
Also I assume you use IFs instead of elseif for a reason? Not like it really matters if done in an array, just curious.
I want to calculate mode for a range.
Range is a variable based on a condition.
Value 1 Value 2 Output
A 10 10
A 12 10
A 10 10
B 5 3
B 3 3
B 2 3
B 3 3
Like in the above case:
I need to calculate the mode(column C), with the range of value 2(column B), with a condition that Value 1(column A)is same in the range.
Sub mode()
Dim count
Dim rng As Range
x = 2
Do While Range("A" & x).Value = Range("A" & x + 1).Value
x = x + 1
Loop
Set rng = Range(Cells(x, 2), Cells(x + 1, 2))
md = WorksheetFunction.mode(rng)
Range("C" & x).Value = md
End Sub
Do You have any clue for that?
If your data are in A1:B7, then put this in C1 and copy down.
It's an array formula so needs to be confirmed with Ctrl, Shift and Enter, and curly brackets will appear round the formula.
=MODE(IF($A$1:$A$7=A1,$B$1:$B$7))
Of course, you could add the formula using VBA.
Enter the following formula as array formula (Ctrl+Shift+Enter) in cell C1 and pull it down
=MODE(IF(A:A=A1,B:B))
Note: In newer Excel versions you might need to use the MODE.SNGL function instead.
Image 1: Column C uses the array formula with an IF condition.
For further information see Conditional mode with criteria.
For reference rather than the best answer, below is the VBA I wrote which completes the same task as the array formula from the other answers:
Sub mode2()
Dim lastrow As Long, x As Long, b As Long
Dim cel As Range, cel2 As Range
Dim rng() As Variant
b = 2
lastrow = Range("A" & Rows.count).End(xlUp).Row
For Each cel In Range("A2:A" & lastrow)
If cel.Value = cel.Offset(1, 0).Value Then
If (Not Not rng) = 0 Then
ReDim rng(0 To 0)
rng(0) = cel.Offset(, 1).Value
Else
ReDim Preserve rng(0 To (cel.Row - b))
rng(cel.Row - b) = cel.Offset(, 1).Value
End If
Else
ReDim Preserve rng(0 To (cel.Row - b))
rng(cel.Row - b) = cel.Offset(, 1).Value
If (Not Not rng) <> 0 Then
Range("C" & cel.Row).Value = Application.WorksheetFunction.mode(rng)
b = cel.Row + 1
Erase rng()
End If
End If
Next cel
End Sub
This is probably not the cleanest or best macro, but it works and maybe it will help someone when a formula isn't an option. (at least it'll be useful for me if I ever go code bowling)
I am currently trying to create a loop that steps through 2 ranges of data. First range is b16-b35 next range is j16-j35. Currently I can only get 1 of the 2 loops to step through.
I started with a For While loop. Using i as a variable for 16-35. When I tried this method I couldnt get the msgbox to print the data. I moved to a For each loop. This gave me the ability to step through 1 cell but not the other.
If [D8] = 2 Then
Dim r As Range
Dim j As Range
Dim jcell As Range
Dim cell As Range
Set r = Range("B16:B35")
Set j = Range("J16:J35")
For Each cell In r
For Each hcell In j
If cell = "" Or cell = "N/A" Then GoTo ENDGAME
MsgBox "pn is " & cell & " route is " & jcell
Next jcell
Next cell
ENDGAME:
End IF
Current method causes the loop to step through all of J for each r. I have tried combining the for each loops with an and statement and it bugs the code.
It seems like really you have one loop (process), it's just that your data feels to be in two different places. Let's loop through B16:B35, referencing the corresponding values in column J as we go:
Sub looper()
Dim r As Range
Dim cell As Range
If [D8] = 2 Then
Set r = Range("B16:B35")
For Each cell In r
If cell = "" Or cell = "N/A" Then GoTo ENDGAME
MsgBox "pn is " & cell & " route is " & cell(1, 9)
Next cell
ENDGAME:
End If
End Sub
So cell is the range object, starting with B16... you can reference a different cell by its offset from a range object... cell(1, 9) means take the cell, look at the same row (1), but the 9th column (count column B as "one", column C as two; column J is nine).
It's normally a good idea to declare variables at the top of the sub, that's why I moved the Dims. Not strictly necessary for this code to work.
Use a counter as the For loop, and use that to set a reference into each range
Dim r As Range
Dim j As Range
Dim jcell As Range
Dim rcell As Range
Dim i as Long
Set r = Range("B16:B35")
Set j = Range("J16:J35")
For i = 1 to r.Rows.Count
Set rcell = r.Cells(i, 1)
Set jcell = j.Cells(i, 1)
MsgBox "pn is " & rcell.Address & " route is " & jcell.Address
Next i
Not completely sure what you are trying to do, but the following should do perform what you would like to..
Btw, defining cell as a range etc. is not best practice. it is better to give it a name other than a function, etc name.
with thisworkbook.sheets(1)
if .range("B8").value = 2 then
for i = 16 to 35
if .range("B" & i).value = "" or .range("B" & i).value = "N/A" then
goto EndGame
else
msgbox "pn is " & .range("B" & i).value & " route is " & .range("J" & i).value
end if
next i
EndGame:
end if
end with
If you want to do 2 loops, first for B , than for J, you can do this. However, if one of the cells in one of the loops contains nothing or n/a -> function will stop. If you want to go to the next (i) ; iteration. you should put the:
EndGame:
just before:
next i
--
dim First_Range_Done as boolean
with thisworkbook.sheets(1)
if .range("B8").value = 2 then
for i = 16 to 35
if First_Range_Done = false then
if .range("B" & i).value = "" or .range("B" & i).value = "N/A" then
goto EndGame
else
msgbox "pn is " & .range("B" & i).value & " route is " & .range("J" & i).value
end if
end if
if First_Range_Done = true
if .range("J" & i).value = "" or .range("J" & i).value = "N/A" then
goto EndGame
else
msgbox "pn is " & .range("B" & i).value & " route is " & .range("J" & i).value
end if
if i = 35 then exit sub
end if
if i = 35 then
First_Range_Done = true
i = 15
end if
next i
EndGame:
end if
end with
Dim r1 As Range
Dim r2 As Range
Dim u As Range
Dim res As String
Set r1 = Range("A1:B1")
Set r2 = Range("C3:D3")
Set u = Union(r1,r2)
res = ""
For Each cell In u
res = res + cell.Value2
Next cell
MsgBox res
Assuming cells have following values:
-------------------
| Address | Value |
-------------------
| A1 | a1 |
| B1 | b1 |
| C3 | c3 |
| D3 | d3 |
-------------------
You would get a1b1c3d3 as result being displayed by MsgBox.
With this method you have the added bonus, you can combine ranges of different dimensions.
The group column in my table contains a value as either 1 or 2 . I want to copy the row with value as 1 to Sheet2 and rows with values as 2 to sheet3 using a button. Also it should show error message if cells are left blank or if value is neither 1 nor 2.
Roll no meter width group
112 150 130 1
Since i am new to coding i have following this approach
check if the cell is empty and generate an error message
check if the cell contains value other than 1 or 2 and generate error message
finally copy the row with values as 1 to Sheet2 and rest all in sheet3
I need help in doing this is an effective way. As i have to keep the size of file down
enter code here
Private Sub CommandButton2_Click()
Dim i As Integer
p = Sheet1.Range("l1").Value 'no. of filled cells in the range
Application.DisplayAlerts = False
Sheet1.Activate
''checking if the range is empty
For i = 29 To p + 29
If Sheet1.Range("l" & i).Value = "" Then
MsgBox ("PLEASE ENTER THE SHRINKAGE GROUP FOR CELL NO. l" & i)
Range("L" & i).Activate
End
End If
Next i
'' checking if the range contains values other than 1 or 2
For i = 29 To p + 29
If Sheet1.Range("l" & i).Value <> 1 And Sheet1.Range("l" & i).Value <> 2 Then
MsgBox ("SHADE GROUP DOES NOT EXIST FOR CELL NO. l" & i)
Range("L" & i).Activate
End
End If
Next i
' sort based on the group
Range("a29:L300").Sort _
Key1:=Range("l29"), Header:=xlYes
'count the number of rolls in group 1
Dim x, y As Long
Dim a, b As Integer
x = Range("L" & Rows.Count).End(xlUp).Row
If x < 29 Then x = 29
a = Application.WorksheetFunction.CountIf(Range("L12:L" & x), 1) + 28
Range("M1").Value = a
' count the number of rolls in group 2
y = Range("L" & Rows.Count).End(xlUp).Row
If y < 29 Then y = 29
b = Application.WorksheetFunction.CountIf(Range("L12:L" & x), 2)
Range("n1").Value = b
'' copying groupwise to different sheet
Sheet1.Range("a29", "l" & a).Copy
Sheet2.Range("a5").PasteSpecial xlPasteAll
Sheet2.Range("a5").PasteSpecial xlPasteValuesAndNumberFormats
'' copying group 2
Sheet1.Range("a" & a + 1, "l" & a + b).Copy
Sheet5.Range("a5").PasteSpecial xlPasteAll
Sheet5.Range("a5").PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Create named ranges for your source data and for the rows after which you want it to be copied. In this example I've used "source", "range1" and "range2". Then the following code copies the source data into the appropriate place:
Sub copyData()
Dim source As Range, range1 As Range, range2 As Range
Dim r As Range
Set source = Range("source")
Set range1 = Range("range1")
Set range2 = Range("range2")
For Each r In source.Rows
If r.Cells(1, 4).Value = 1 Then
copyRow r, range1
ElseIf r.Cells(1, 4).Value = 2 Then
copyRow r, range2
Else
' handle error here
End If
Next r
End Sub
Sub copyRow(data As Range, targetRange As Range)
Set targetRange = targetRange.Resize(targetRange.Rows.Count + 1, targetRange.Columns.Count)
For i = 1 To 3
targetRange.Cells(targetRange.Rows.Count, i).Value = data.Cells(1, i).Value
Next i
End Sub
There's probably a much more elegant way of doing this involving array formulae, but this should do the trick.
For validating that each cell contains only "1" or "2", you can include additional code where I've put a comment, but you'd be better off handling this as a data validation.