I am trying to add a line of code in VBA that will ask if the range has a value of HP-1 to then to make it 16 GA. else, it needs to be 26 GA.
Currently code just converts everything to 26 GA.
Sheets("TRIM").Select
Range("D13").Select
Do Until ActiveCell.Offset(0, -1).Value = ""
If ActiveCell.Value <> "" Then
ActiveCell.Value = "26 GA."
End If
ActiveCell.Offset(1, 0).Select
Loop EndIf
So I need to add in something that will do the HP-1 condition...I did try to make an Else statement but getting NO compile errors but getting this one.
this error has nothing to do with 32bit/64 bit as we are all still using 32bit Excel with 32bit VBA codeI'm sure it is pretty easy but can't seem to get the syntax down...
Any suggestions?
This is the original function in total...
Nest your If Statements:
Note: depending on your data layout, you may need to find a different way of defining RG, however, this should work.
Option Explicit
Sub Example()
Dim WS As Worksheet
Dim RG As Range
Dim CL As Range
Set WS = Worksheets("TRIM")
' Build Range "RG" from D13 to last used cell in D column
With WS
Set RG = .Range("D13", .Range("D" & Rows.Count).End(xlUp))
End With
' For each cell in the range "RG"
For Each CL In RG.Cells
If CL.Value <> "" Then 'Check if the value of the cell is ""
If CL.Value = "HP-1" Then 'Check if the value of the cell is "HP-1"
CL.Value = "16 GA" 'Change Value of the cell
Else
CL.Value = "26 GA" 'Change Value of the cell
End If
End If
Next CL
End Sub
Populate Cells Conditionally
Replace your code with the following.
Dim ws As Worksheet: Set ws = Sheets("TRIM")
If ws.Visible = xlSheetVisible Then
Dim cell As Range: Set cell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
Dim rg As Range, rCount As Long
With ws.Range("D13")
rCount = cell.Row - .Row + 1
If rCount > 0 Then Set rg = .Resize(rCount)
End With
If Not rg Is Nothing Then ' data found
For Each cell In rg.Cells
If StrComp(CStr(cell.Value), "HP-1", vbTextCompare) = 0 Then
cell.Value = "16 GA."
Else ' is not 'HP-1'
cell.Value = "26 GA."
End If
Next cell
'Else ' no data found; do nothing!?
End If
'Else ' worksheet not visible; do nothing!?
End If
Related
I am beginner at VBA, I am stuck plz help. In this image(linked at the end of paragraph), I am trying to insert line above the cells which contains different name than the name of upper cell. Plz tell me if there is an easier way to do this or how to apply the given if else condition to whole "G" Column...
Still I am adding my code below if you don't need the image...
Sub ScanColumn()
'Application.ScreenUpdating = False
Dim varRange As Range
Dim currentCell As String
Dim upperCell As String
Dim emptyCell As String
currentCell = ActiveCell.Value
bottomCell = ActiveCell.Offset(1, 0).Value
emptyCell = ""
Dim intResult As Integer
intResult = StrComp(bottomCell, currentCell)
Dim emptyResult As Integer
emptyResult = StrComp(currentCell, emptyCell)
'I want to apply below condition to whole G column in used range
If emptyResult = 0 Then
ActiveCell.Select
ElseIf intResult = 0 Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1).EntireRow.Insert
ActiveCell.Offset(2, 0).Select
End If
End Sub
Here you have, just call the function "evaluateColumn" and pass the parameters, as example the "trial" sub.
Function evaluateColumn(column As String, startRow As Long, wsh As Worksheet)
Dim lastRow As Long
lastRow = wsh.Range(column & wsh.Rows.Count).End(xlUp).Row
Dim i As Long: i = startRow
Do While i < lastRow
If wsh.Cells(i, column).Value <> wsh.Cells(i + 1, column).Value And wsh.Cells(i, column).Value <> "" And wsh.Cells(i + 1, column).Value <> "" Then
wsh.Range(column & i + 1).EntireRow.Insert shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
i = i + 1
lastRow = lastRow + 1
End If
i = i + 1
Loop
End Function
Sub trial()
evaluateColumn "G", 2, ThisWorkbook.Worksheets("Sheet2")
End Sub
As you can see from the difference between my answer and the one below, your question isn't entirely clear. My code is an event procedure. It will run automatically, as you select a cell within the used range of column G.
If the value of the selected cell is the same as the cell below it the next row's cell will be selected.
If there is a value in either of the two cells, a blank row will be inserted and that row's cell selected. (If you want another row enable the row below the insertion.)
If either of the above conditions are true, do nothing and proceed with the selection the user made.
In order to let this code work it must be installed in the code sheet of the worksheet on which you want the action. It will not work if you install it in a standard code module, like Module1.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim TriggerRange As Range
Dim Off As Long ' offset from Target for selection
' if more than one cell is selected choose the first cell
If Target.Cells.CountLarge > 1 Then Set Target = ActiveCell
Set TriggerRange = Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
' this code will run only if a cell in this range is selected
' Debug.Print TriggerRange.Address(0, 0)
If Not Application.Intersect(Target, TriggerRange) Is Nothing Then
Application.EnableEvents = False
With Target
If .Value = .Offset(1).Value Then
Off = 1
ElseIf WorksheetFunction.CountA(.Resize(2, 1)) Then
Rows(.Row).Insert
' Off = 1 ' or -1 to change the selection
End If
.Offset(Off).Select
End With
Application.EnableEvents = True
End If
End Sub
I want to update the filtered values of a column using vba macros. Eg. Flag column has values Y and N and I have filtered to N. Now I want to update the value "N" to some other value. Below is a sample image. Can someone please suggest ?
Give this a try:
Sub Framm()
Dim rng As Range, cell As Range
Set rng = ActiveSheet.AutoFilter.Range
Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, 1)
For Each cell In rng.Columns(1).Cells.SpecialCells(xlCellTypeVisible)
cell.Value = "changed"
Next cell
End Sub
Here is my code:
Sub SubChangeAutofilteredValues()
'Declarations.
Dim RngRange01 As Range
Dim StrOldValue As String
Dim StrNewValue As String
'Setting variables.
StrOldValue = "N"
StrNewValue = "K"
'Autofiltering.
ActiveSheet.AutoFilter.Range.AutoFilter Field:=1, Criteria1:=StrOldValue
'Verifying if any match has been found.
If Cells(ActiveSheet.AutoFilter.Range.Rows.Count + 1, 1).End(xlUp).Row = 1 Then
MsgBox "No records found.", , "No records found"
Exit Sub
End If
'Setting the variable.
With ActiveSheet.AutoFilter.Range
Set RngRange01 = .Resize(.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
'Changing the values.
RngRange01.Value = StrNewValue
End Sub
I am new to VBA and am trying to delete everything outside of the specified print area for every worksheet in my file. I have code that is working alright, but for some tabs, the print area begins in column B, and I need to delete column A because it is not in the print area. I cannot figure out how to rewrite my code to ensure that the column to the left of the specified print area will get deleted.
Dim FirstEmptyRow As Long
Dim FirstEmptyCol As Integer
Dim rng As Range
With ActiveSheet.PageSetup
If .PrintArea = "" Then
Set rng = ActiveSheet.UsedRange
Else
Set rng = ActiveSheet.Range(.PrintArea)
End If
End With
FirstEmptyCol = rng.Cells(rng.Cells.Count).Column + 1
FirstEmptyRow = rng.Rows.Count + rng.Cells(1).Row
Range(Cells(1, FirstEmptyCol), Cells(1, 256)).EntireColumn.Delete
Range(Cells(FirstEmptyRow, 1), Cells(Rows.Count, 1)).EntireRow.Delete
Try adding this additional code:
If rng.Column > 1 Then
Range(Cells(1, 1), Cells(1, rng.Column - 1)).EntireColumn.Delete
End If
You could try this. Find the PrintAreaand then using Intersect you could loop through the cells and find which cells are not in the PrintArea, Union the cells and then delete them at the end. Doing it this way you can delete everything that's not a part of the PrintArea, all at the same time. Hope this helps:
Sub testPrintArea()
Dim printAreaRange As Range
With ActiveSheet.PageSetup
If .PrintArea = "" Then
Set printAreaRange = ActiveSheet.UsedRange
Else
Set printAreaRange = ActiveSheet.Range(.PrintArea)
End If
End With
' Get non print area cells and union them
Dim nonPrintAreaCells As Range
Dim cell As Range
For Each cell In ActiveSheet.UsedRange
If Intersect(cell, printAreaRange) Is Nothing Then
If nonPrintAreaCells Is Nothing Then
Set nonPrintAreaCells = cell
Else
Set nonPrintAreaCells = Union(nonPrintAreaCells, cell)
End If
End If
Next cell
' do whatever...
nonPrintAreaCells.Value = ""
End Sub
You can use the Column and Row properties of a range to determine where it starts, like this
Sub DeleteOutsidePrintArea(ws As Worksheet)
Dim rng As Range
With ws
If .PageSetup.PrintArea = vbNullString Then
Set rng = .UsedRange
Else
Set rng = .Range(.PageSetup.PrintArea)
End If
' Delete columns to left, if any
If rng.Column > 1 Then
.Columns(1).Resize(, rng.Column - 1).Delete
End If
' Delete rows above, if any
If rng.Row > 1 Then
.Rows(1).Resize(rng.Row - 1).Delete
End If
' Delete columns to right, if any
If rng.Columns.Count < (.UsedRange.Columns.Count + .UsedRange.Column - 1) Then
.Columns(rng.Columns.Count + 1).Resize(, .UsedRange.Columns.Count + .UsedRange.Column - 1 - rng.Columns.Count).Delete
End If
' Delete rows below, if any
If rng.Rows.Count < (.UsedRange.Rows.Count + .UsedRange.Row - 1) Then
.Rows(rng.Rows.Count + 1).Resize(.UsedRange.Rows.Count + .UsedRange.Row - 1 - rng.Rows.Count).Delete
End If
End With
End Sub
Call it like this
Sub Demo()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook '<~~~ Adjust to suit
For Each ws In wb.Worksheets
DeleteOutsidePrintArea ws
Next
End Sub
I'm trying to update a sheet with an import of a .CSV file..
I can read and update all the information. After the update I want to remove some data. All the rows with D empty must be deleted (whole row).
For that, I have a foreach that checks D3:D486 (is last row).
After running the macro, there are some rows deleted, but not all the rows.
Dim rCell As Range
Dim rRng As Range
Debug.Print CStr(LastRow)
Set rRng = Worksheets("sheet1").Range("D3:D" + CStr(LastRow))
For Each rCell In rRng.Cells
If Not IsEmpty(rCell) Then
Debug.Print rCell.Row
Else
Debug.Print "Empty"
Worksheets("sheet1").Rows(rCell.Row).Delete
End If
Next rCell
I guess there is a problem with the for-each.. By example, If he delete row 100, the next time he goes to row 101.. But thats previous row 102..
I can save the cells maybe in an array, but then it would be the same.
Except if I go the other way (from bottom to top). How can I solve this?
i think you've answered your own question: from bottom to top...
and you can try range.EntireRow.Delete method too, something like below
Dim rCell As Range
Dim lastRow, i
lastRow = 1000
For i = lastRow To 1 Step -1
' if condition met
Worksheets("Sheet1").Range("D:" + i).EntireRow.Delete
Next
I would do it like this:
Dim i As Integer
Dim rRng As Range
Debug.Print CStr(LastRow)
Set rRng = Worksheets("sheet1").Range("D3:D" + CStr(LastRow))
For i = 1 To rRng.Cells.Count
If Not IsEmpty(Worksheets("Sheet1").Range("D:" + i).Value) Then
Debug.Print rCell.Row
Else
Debug.Print "Empty"
Worksheets("Sheet1").Range("D:" + i).EntireRow.Delete
i = i - 1
End If
Next
Rex answer is correct, if you want to get cute you can also do it this way:
Sub DeleteRowsWithCriteria()
Dim rng As Range, rngCell As Range, rngDelete As Range
Set rng = Worksheets("sheet1").UsedRange.Columns("D:D").Cells 'Watch out here, if columns A-C are not all used, this doesn't work
For Each rngCell In rng
If rngCell.Value = "" Then
If rngDelete Is Nothing Then
Set rngDelete = rngCell
Else
Set rngDelete = Union(rngDelete, rngCell)
End If
End If
Next rngCell
rngDelete.EntireRow.Delete xlShiftUp
End Sub
Have a range of cell with column headings as weeks In the range of cells I want to look for a number, say
1 if it finds a 1 then look at a column in said row for a variable, 2 or 4 whatever Now I want to put a triangle (can be copy and paste a cell) in the cell that has the "1" in it then skip over the number of week variable and add another triangle and keep doing this until the end of the range. Then skip down to the next row and do the same, until the end of the range.
Then change to the next page and do the same thing... through the whole workbook.
I think I have it done, don't know if it's the best way.
I get a error 91 at the end of the second loop, the first time the second loop ends it goes through the error code.
The second time the second loop ends it errors.
I don't understand it runs through once, but not twice.
Sub Add_Triangles2()
Dim Rng As Range
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Dim ws As Worksheet
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Worksheets(1).Activate
Worksheets(1).Range("A1").Select ' Has item to be pasted (a triangle)
Selection.Copy
For Each ws In Worksheets
Worksheets(ws.Name).Activate
With Range("C4:G25")
Set Rng = .Find(1, LookIn:=xlValues)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Activate
ActiveSheet.Paste
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
End With
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub
I was not able to get an Error 91 using the data set I built from your explanation, maybe a screenshot of the layout could help recreate the issue.
However, I would do something like this, it will look at the value of each cell in the range C4:G25, and if it equals 1, it will paste the symbol stored in Cell A1.
Sub Add_Triangles2()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
End If
Next Rng
Next ws
End Sub
I got it....
Sub Add_TriWorking()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
Rng.Activate
ActiveCell.Copy
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
End If
Next Rng
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub