I have two spreadsheets, one contains programs and one projects. I use D loops to look at projects, within programs, within countries. I am trying to figure out if a set of cells for each project is blank. I have tried a few things. In the case below sustTrue should stay at 0 if rangeVar is blank for all the projects, but it does not. Please help!
Sub NO_Sheet()
Sheets("Program_FINAL").Select
Range("C2").Select ' C column is country
Dim IndicatorLineIterator
Do Until IsEmpty(ActiveCell) ' loop until country is blank
IndicatorLineIterator = 61
Dim PRGNum
PRGNum = ActiveCell.Offset(0, -2).Value ' Identify the program number
Sheets("Project_FINAL").Select
Range("A2").Select ' A column is the project number
Dim rangeVar, sustTrue
sustTrue = 0
Do Until IsEmpty(ActiveCell) ; loop until Project number is blank
If PRJNum = ActiveCell.Value Then
'rangeVar = ("O" & ActiveCell.Row & ":S" & ActiveCell.Row)
rangeVar = Range(ActiveCell.Offset(0, 14) & ":" & ActiveCell.Offset(0, 17))
If Not IsEmpty(rangeVar) Then
sustTrue = sustTrue + 1
MsgBox (sustTrue)
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
End If
'Sheets(SheetADPName).Range("M16").Value = sustTrue
Sheets("Program_FINAL").Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub
I kept working on it and the following worked for me. There is probably a more streamlined way to do this, but this works!
If Not ActiveCell.Offset(0, 14) = "" Or Not ActiveCell.Offset(0, 15) = "" Or Not ActiveCell.Offset(0, 16) = "" Or Not ActiveCell.Offset(0, 17) = "" Then
sustTrue = sustTrue + 1
MsgBox (sustTrue)
End If
Your rangeVar is not a range object.
Strongly type your variables:
Dim rangeVar as Range
Dim sustTrue as Long 'Or As Integer
Dim cl as Range
Then use the Set keyword to assign object variables and instead of concatenating, we can just list the two cells separated by a comma, and this will create the range:
Set rangeVar = Range(ActiveCell.Offset(0, 14), ActiveCell.Offset(0, 17))
Further, you can't reliably use the IsEmpty on a range array, only a single cell or other simple data type. You can get around this by iterating the range:
For each cl in rangeVar.Cells
If Not IsEmpty(cl.Value) Then
sustTrue = sustTrue + 1
End If
Next
MsgBox (sustTrue)
The IsEmpty function may not be a foolproof way to do this check. But the rest of the logic above should help. Let me know if you have trouble with the IsEmpty part.
Another alternative would be to simply subtract the number of blanks from the total number of cells in that range (again, may not be 100% reliable if the cells aren't "truly" blank...)...
sustTrue = rangeVar.Cells.Count - rangeVar.SpecialCells(xlCellTypeBlanks).Cells.Count
RangeVar is a range object. You would need to do Isempty(RangeVar.Value)
I think this has been answered already here: Using VBA to check if below cell is empty
Related
I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to use a loop in a column X who will affect a column Y (cell on the same line).
To give you an example:
Column A: I have all Production Order (no empty cell)
Column B: Cost of goods Sold (Sometimes blank but doesn't matter)
I actually pull information from SAP so my Column B is not in "Currency".
The action should be:
If A+i is not empty, then value of B+i becomes "Currency".
It's also for me to get a "generic" code that I could use with other things.
This is my current code...
Sub LoopTest()
' Select cell A2, *first line of data*.
Range("A2").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Style = "Currency"
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Another example, getting Last Row, in case your data contains any blank rows.
Sub UpdateColumns()
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 2).NumberFormat = "$#,##0.00"
End If
Next r
End Sub
I can see I was a little slower than the others, but if you want some more inspiration, heer is a super simple solution (as in easy to understand as well)
Sub FormatAsCurrency()
'Dim and set row counter
Dim r As Long
r = 1
'Loop all rows, until "A" is blank
Do While (Cells(r, "A").Value <> "")
'Format as currency, if not blank'
If (Cells(r, "B").Value <> "") Then
Cells(r, "B").Style = "Currency"
End If
'Increment row
r = r + 1
Loop
End Sub
Try the following:
Sub calcColumnB()
Dim strLength As Integer
Dim i As Long
For i = 1 To Rows.Count
columnAContents = Cells(i, 1).Value
strLength = Len(columnAContents)
If strLength > 0 Then
Cells(i, 2).NumberFormat = "$#,##0.00"
End If
Next i
End Sub
Explanation--
What the above code does is for each cell in Column B, so long as content in column A is not empty, it sets the format to a currency with 2 decimal places
EDIT:
Did not need to loop
Here's a really simply one, that I tried to comment - but the formatting got messed up. It simply reads column 1 (A) for content. If column 1 (A) is not empty it updates column 2 (B) as a currency. Changing active cells makes VBA more complicated than it needs to be (in my opinion)
Sub LoopTest()
Dim row As Integer
row = 1
While Not IsEmpty(Cells(row, 1))
Cells(row, 2).Style = "Currency"
row = row + 1
Wend
End Sub
I'm currently trying to use a Do Until within a For each but I'm having a problem. What I'm trying is to Do Until selection value equals the value selected for the For each section in the following code:
Private Sub Copiar()
Dim Eselect As Variant
Dim vItem As Variant
Dim Col As Integer
Eselect = Array(CBE1.Value, CBE2.Value, CBE3.Value, CBE4.Value, CBE5.Value)
For Each vItem In Eselect
Range("C2").Select
Do Until Selection.Value = vItem.Value
Selection.Offset(0, 1).Select
Loop
Col = ActiveCell.Column
Columns(Col).Copy
Sheets(2).Active
Range("A1").Select
If Range("A1") = "" Then
Columns(Col).Copy
Else
Do Until Selection.Value = ""
Offset.Selection(0, 1) = Selection.Value
Loop
Columns(Col).Copy
End If
Next
End Sub
The problem is specifically where is says "Do Until Selection.Value = vItem.Value" because I can't use vItem.Value and I don't know what I should use for to search until it find the value that For Each has selected. (I'm obviously just learning VBA).
The whole idea is for it to search a specific value (multiple times, one for each ComboBox Value: CBEi) in a row and return the column, then copy that column on another sheet.
Any help would be appreciated.
Vicente.
I have a column of numbers in an Excel spreadsheet, which have been produced by an accelerometer and recorded by a data logger. The problem with the accelerometer is that when it is stationary it produces a lot of 'noise' values, which are always the same: 1.2753, 1.6677, 2.0601, 2.5506, 2.943, and 3.4335.
The first value in this column which is NOT one of the above numbers represents when the accelerometer begins to detect motion. Equally, the last value which is not one of the above numbers represents when the accelerometer stops detecting motion.
I have VBA code that produces an Acceleration vs Time graph using the above column, but it also includes all these 'noise' values. I am trying to trim these beginning and end noise values out of the column so that only motion is shown on the graph.
Is there some way of using VBA to determine the first value in the column that is NOT one of the above noise values? I'm guessing the same code can be tweaked to find the last.
I hope that I've explained this clearly. I wasn't able to find any answers to this one.
Thanks!
Here is an example for column A. We make an array of "bad" values and then loop down the column examining each item until we find one that is not "bad"
Sub FirstGood()
Dim v As Double, FoundIt As Boolean
bad = Array(1.2753, 1.6677, 2.0601, 2.5506, 2.943, 3.4335)
For i = 1 To 9999
v = Cells(i, "A").Value
FoundIt = True
For j = 0 To 5
If bad(j) = v Then FoundIt = False
Next j
If FoundIt Then
MsgBox "Found valid data on row # " & i
Exit For
End If
Next i
End Sub
This is only demo code. You must adapt it by fixing the loop limits, the column id, the response, etc.
this is time and motion coding.
Sub StartWatch()
' store time in start column
Dim rngTemp As Range
Set rngTemp = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0)
rngTemp = Now()
End Sub
Sub StopWatch()
' store time in stop column
' copy previous formula down
Dim rngTemp As Range
Set rngTemp = ActiveSheet.Range("B65536").End(xlUp).Offset(1, 0)
rngTemp = Now()
rngTemp.Offset(-1, 1).AutoFill Destination:=Range(rngTemp.Offset(-1, 1), rngTemp.Offset(0, 1)), Type:=xlFillDefault
Range("D65536").End(xlUp).Offset(1, 0).Select
End Sub
Dim PASSWORD As String
On Error GoTo ERRORH:
PASSWORD = InputBox("Enter Password to Close file")
If PASSWORD = "learnmore" Then
Else
Cancel = True
End
If ERRORH:
If Err.Number = 13 Then
Err.Clear
Cancel = True
End If
You don't even necessarily need to use VBA---you could have the "noise" values in a specific range of your spreadsheet, and add a is_noise column to your data, which uses a VLOOKUP or COUNTIF function to see if the value appears in your table of noise values. Then your chart would just exclude those values. That way, your spreadsheet would also be more flexible: If new noise values pop up, you just have to change the spreadsheet rather than updating your VBA code.
Option Explicit
Sub StartWatch()
' store time in start column
Dim rngTemp As Range
Set rngTemp = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
rngTemp = Now()
End Sub
Sub StopWatch()
' store time in stop column
' copy previous formula down
Dim rngTemp As Range
Set rngTemp = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
rngTemp = Now()
If rngTemp.Row <> 2 Then
rngTemp.Offset(-1, 1).AutoFill Destination:=Range(rngTemp.Offset(-1, 1), rngTemp.Offset(0, 1)), Type:=xlFillDefault
Range("D65536").End(xlUp).Offset(1, 0).Select
Else
rngTemp.Offset(, 1).Formula = "=$B2-$A2"
End If
End Sub
I am working on a Macro in Excel that needs to iterate through an entire column and find clusters of non-zero data, add up the data and store the result near the mentioned cluster. Then it continues down the column looking for other clusters and doing the same thing.
That being said, I am trying to store a reference to the "target" cell (where the addition of the cluster will be stored) in a variable, and then using that variable to access the "value" property of the cell so that I can make changes to it.
Here's the code:
Sub addNonZeroes()
Dim targetCell
' Select cell E5, *first line of data*.
Range("E5").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value <> 0 Then
targetCell = ActiveCell.Offset(1, 0)
Do Until ActiveCell.Value = 0
'ERROR OCCURS HERE
targetCell.Value = ActiveCell.Value + targetCell.Value
ActiveCell.Offset(0, 1).Select
Loop
End If
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Source of the code error
The error occur because your targetCell is not really defined.
You should:
define your variable and type it
use the Set keyword to assign an object
Here is your code adapted:
Sub addNonZeroes()
Dim targetCell As Range
' Select cell E5, *first line of data*.
Range("E5").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value <> 0 Then
Set targetCell = ActiveCell.Offset(1, 0)
Do Until ActiveCell.Value = 0
'ERROR OCCURS HERE
targetCell.Value = ActiveCell.Value + targetCell.Value
ActiveCell.Offset(0, 1).Select
Loop
End If
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Using Select and Offset is a bad idea
Yet, you should consider not using Select and Offset because this is very slow.
A better way would be this kind of loop:
Dim c As Range
For Each c in Range("E5:E100")
If c.Value <> 0 Then
'do whatever
End If
Next c
Using range to array is a very VBA way
Note that you can use a Variant to store every value of a range into an array, something like this:
Dim arr As Variant, i As Integer
arr = Range("E5:E100").Value
For i = LBound(arr , 2) To UBound(arr , 2)
'check for any empty value
Next i
See this thread for more examples: Array from Range in Excel VBA
This macro is to move records from a master sheet to other sheets based on criteria from column F.
A type mismatch error occurs in the "Termination" case where it is selecting the cell "B2".
I tried several different options, but each ends up with a different error.
Public Sub moveToSheet()
Sheets("Master").Select
' Find the last row of data
FinalRow = Range("E65000").End(xlUp).Row
'Loop through each row
For x = 2 To FinalRow
' Decide where to copy based on column F
ThisValue = Range("F" & x).Value
Select Case True
Case ThisValue = "Hiring "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Hiring").Select
Sheets("Hiring").Range("B2:W2500").Clear
Sheets("Hiring").Cells("B2").Select
ActiveSheet.Paste
Sheets("Master").Select
Case ThisValue = "Re-Hiring "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Hiring").Select
Sheets("Hiring").Range("B2:W2500").Clear
Sheets("Hiring").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Termination "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Terminations").Select
Sheets("Terminations").Range("B2:W2500").Clear
Sheets("Terminations").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Transfer "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Transfers").Select
Sheets("Transfers").Range("B2:W2500").Clear
Sheets("Transfers").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Name Change "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Name Changes").Select
Sheets("Name Changes").Range("B2:W2500").Clear
Sheets("Name Changes").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Address Change "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Address Changes").Select
Sheets("Address Changes").Range("B2:W2500").Clear
Sheets("Address Changes").Cells("B2").Select
ActiveSheet.Paste
Case Else
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("New Process").Select
Sheets("New Process").Range("B2:W2500").Clear
Sheets("New Process").Cells("B2").Select
ActiveSheet.Paste
End Select
Next x
End Sub
There are a couple problems, first, you need to use the syntax Range("B2").Select to select the cell. BUT, since you selected the entire row from the master sheet, you can't copy the entire row into B2, because the ranges aren't the same size, so you need to select the first cell (A2) instead.
So, the entire case statement should look like this:
Case ThisValue = "Termination "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Terminations").Activate
Range("A2").Select
ActiveSheet.Paste
There are a number of issues
No need to Select, use variables instead
Dim all your variables - help with debugging and learning
Some general good practice techniques will help
Here's a (partially) refactored version of your code
Public Sub moveToSheet()
Dim wb As Workbook
Dim shMaster As Worksheet, shHiring As Worksheet
Dim rngMaster As Range
Dim x As Long
Dim rw As Range
Set wb = ActiveWorkbook
Set shMaster = wb.Worksheets("Master")
Set shHiring = wb.Worksheets("Hiring")
' etc
' Find the data
x = shMaster.UsedRange.Count ' trick to reset used range
Set rngMaster = shMaster.UsedRange
'Loop through each row NOTE looping thru cells is SLOW. There are faster ways
For Each rw In rngMaster.Rows
' Decide where to copy based on column F
Select Case Trim$(rw.Cells(1, 6).Value) ' Is there really a space on the end?
Case "Hiring"
shHiring.[B2:W2500].Clear
rw.Copy shHiring.[B2]
' Case ' etc
End Select
Next rw
This is what I basically use to do exactly what you are talking about. I have a "master" sheet that is several thousand rows and a couple hundred columns. This basic version only searches in Column Y and then copies rows. Because other people use this, though, I have several template worksheets that I keep very hidden so you can edit that out if you don't want to use templates. I also can add additional search variables if needed and simply adding in another couple of lines is easy enough. So if you wanted to copy rows that match two variables then you'd define another variable Dim d as Range and Set d = shtMaster.Range("A1") or whatever column you wanted to search the second variable. Then on the If line change it to If c.Value = "XXX" and d.Value = "YYY" Then . Finally make sure you add an offset for the new variable with the c.offset (so it would have a line Set d = d.Offset(1,0) at the bottom with the other). It really has turned out to be pretty flexible for me.
Sub CreateDeptReport(Extras As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim arrColsToCopy
Dim c As Range, x As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error GoTo Err_Execute
arrColsToCopy = Array(1, 3, 4, 8, 25, 25, 21, 16, 17, 15, 31, 7) 'which columns to copy ?
Set shtMaster = ThisWorkbook.Sheets("MasterSheet")
Set c = shtMaster.Range("Y5") 'Start search in Column Y, Row 5
LCopyToRow = 10 'Start copying data to row 10 in Destination Sheet
While Len(c.Value) > 0
'If value in column Y equals defined value, copy to destination sheet
If c.Value = “XXX” Then
'only create the new sheet if any records are found
If shtRpt Is Nothing Then
'delete any existing sheet
On Error Resume Next
ThisWorkbook.Sheets("Destination").Delete
On Error GoTo 0
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtMaster
Set shtRpt = ThisWorkbook.Sheets(shtMaster.Index + 1)
shtRpt.Name = "Destination" 'rename new sheet to Destination
‘Optional Information; can edit the next three lines out -
Range("F1").Value = "Department Name"
Range("F2").Value = "Department Head Name"
Range("B3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
End If
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = _
c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1 'next row
End If
Set c = c.Offset(1, 0)
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Range("A9").Select 'Position on cell A9
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Also, if you wanted then you could remove the screenupdating lines. As stupid as it sounds some people actually like to see excel working at it. With screenupdating off you don't get to see the destination sheet until the copying is completed, but with updating on the screen flickers like crazy because of it trying to refresh when each row is copied. Some of the older people in my office think that excel is broken when they can't see it happening so I keep screenupdating on most of the time. lol
Also, I like having the templates because all of my reports have quite a few formulas that need to be calculated after the information is broken down so I am able to keep all the formulas where I want them with a template. Then all I have to do is run the macro to pull from the master sheet and the report is ready to go without any further work.