I am trying to create a code that will run through specific row and if it finds cell with value "1" it adds column next to it and moves on.
I stumbled upon a problem, at this point when my macro finds cell with value 1 it starts adding infinite numbers of columns instead of one and moving to the next cell. Can you help me?
Sub makro()
Set zakres = ActiveSheet.UsedRange
For Each Cell In zakres.Rows(3).Cells
If Cell.Value = 1 Then
Cell.EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next Cell
End Sub
You can try this which will insert columns before any cell with 1 in it.
Edit1: Iterate on Row3 only
Sub Test()
Dim r As Range, c As Range, ir As Range
Dim i As Long
With Activesheet
Set r = .Range("A3", .Cells(3, .Columns.Count).End(xlToLeft))
End With
For i = r.Cells.Count To 1 Step -1
If r.Cells(i).Value = 1 Then r.Cells(i).EntireColumn.Insert xlToRight
Next
End Sub
We used the classic For Loop instead of For Each.
This way we can easily loop backwards. HTH.
Related
I just want to know how to loop through the non blank cells on Column A. What I'm trying to do is copy the contents on [A1:B1] to be added on top of each non blank cells on Column A. So far I have counted the non blank cells on column A but I'm stuck. I know that an Offset function should be used for this.
Here's my code so far:
Dim NonBlank as Long
NonBlank = WorksheetFunction.CountA(Worksheet(1).[A:A])
For i = 1 to NonBlank
[A1:B1].Copy Offset(1,0). "I'm stuck here"
Next i
If you are trying to fill the headers for each Product, try this...
Sub FillHeaders()
Dim lr As Long
Dim Rng As Range
lr = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
On Error Resume Next
Range("A1:B1").Copy
For Each Rng In Range("A3:A" & lr).SpecialCells(xlCellTypeConstants, 2).Areas
If Rng.Cells(1).Value <> Range("A1").Value Then
Rng.Cells(1).Offset(-1, 0).PasteSpecial xlPasteAll
End If
Next Rng
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
As example to simulate the effect of Ctrl-Down from Cell A1 and display the Address, Value in the Immediate Window:
Sub HopToNextNonBlankCellBelow()
Dim oRng As Range
Set oRng = Range("A1")
Debug.Print "Cell Address", "Cell Value"
Do
Set oRng = oRng.End(xlDown)
If Not IsEmpty(oRng) Then Debug.Print oRng.Address(0, 0), oRng.Value
Loop Until oRng.Row = Rows.Count
Set oRng = Nothing
End Sub
Try this... I've (probably) overcounted the rows at 1000, but it likely won't make a difference with your performance. If you wanted to be more precise, there are hundreds of articles on how to find the last row of a range. As for the Offset function, it references a cell in relation to the one we're looping through. In the example below, the code is saying cell.offset(0,1) which means one cell to the right of the cell we are currently looping through. A clearer (less loopy!) example would be if you typed: Range("A10").offset(0,1) it would be the same as typing Range("B10")
Dim Cell As Range
For Each Cell In Range("A2:A1000").Cells
If Not IsEmpty(Cell) Then
Cell.Offset(0, 1).Value = Cell.Value
End If
Next Cell
I've been searching for more than 3 days to build this VBA Macro I need so any help would be much I appreciated.I want to build a macro with a Loop that will search for certain fixed text (this will be my reference step text) in a column let us say it's Column C, once it find that text will offset to the next cell to the left in Column B and this cell will have a variable text that I want to copy down to just before the next text step of C. I think Macro will be by making double loops, first loop to search for the text in column C and once find it will offset to adjacent cell of column B then another loop to copy & paste the value of cell of column B down to before the next text step of C and first loop will be performed on all column c. my trial with first loop was some how successful as I tried to make it either with identifying the certain text as a Boolean or using For Each loop. but my hard part was always in the second loop to increment the text of column B down to the cell before the next step of column C and relate the two loops to each other.
Below are my trials if you could help in them I would be much appreciated.
Sub test()
Dim i As Long
Dim ilastrow As Long
Dim n As string
ilastrow = Range("C1").End(xlDown).Row
Dim r As Range, cell As Range
Set r = Range("C1").End(xlDown).Row
For Each cell In r
If cell.Value = "TH" Then
ActiveCell.Offset(rowOffset:=0, columnOffset:=-1).Activate
n = ActiveCell.Value
'from here I want to copy n down to every cell until before next "TH" in column C then proceed with next "TH" as n will be changed and so on for all "TH" in Colmun C
End If
Next
End Sub
what I want to do with picture
any help will be much appreciated thanks in advance :)
This should do what you want:
Option Explicit
Sub test()
Dim sht As Worksheet
Set sht = ActiveSheet
With sht
Dim ilastrow As Long
ilastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
Dim r As Range, cell As Range, prevCell As Range
Set r = .Range("C1:C" & ilastrow)
Set prevCell = Nothing
For Each cell In r
If cell.Value = "TH" Then
If Not prevCell Is Nothing Then
prevCell.Offset(1, -1).Resize(cell.Row - prevCell.Row - 1, 1).Value = prevCell.Offset(, -1).Value
Set prevCell = cell
Else
Set prevCell = cell
End If
End If
Next
ilastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
prevCell.Offset(1, -1).Resize(ilastrow - prevCell.Row, 1).Value = prevCell.Offset(, -1).Value
End With
End Sub
I have section title cells set at 10 pt font while all other data is set at 9 point font in column A. I am trying to write a vba macro to loop through column A to move each title cell down one row(because the csv leaves a blank cell below them) then move on to the next title cell in the column. Here is my attempt but I'm not sure what I'm doing wrong here.
Sub FontSpacing()
Dim Fnt As Range
For Each Fnt In Range("A8:A5000")
If Fnt.Font.Size = "10" Then
ActiveCell.Cut Destination:=ActiveCell.Offset(",1")
End If
Next
Try this
Sub FontSpacing()
Dim r As Range
For Each r In ThisWorkbook.Worksheets("Sheet1").Range("A8:A5000")
If r.Font.Size = 10 Then
r.Offset(1,0).Value = r.Value
r.Value = vbNullString
End If
Next r
End Sub
The issues:
Offset(",1") shouldn't have the speech marks. I.e. it should be Offset(0,1). In fact, if you want to paste to the row below, then it should be Offset(1,0).
Avoid using ActiveCell. It's not the cell that is looping through your range, it's just the cell that was active on the worksheet when you ran the sub.
Fnt is a bad name for a range, it's probably the reason you got confused. When declaring (dimensioning) a range, try to give it a name that makes it clear you're working with a range.
Extra:
Fully qualify your range reference to avoid an implicit reference to the ActiveSheet e.g. ThisWorkbook.Worksheets("Sheet1").Range("A1").
Avoid cutting an pasting by setting the Value directly
Your indentation is out, which makes it look like a complete Sub, but it's missing the End Sub.
Not sure if you meant 1 Row below or 1 Column right so:
To shift 1 Column:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
cell.Offset(0, 1).Value = cell.Value
cell.Clear
End If
Next
End Sub
To shift 1 Row:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
a = cell.Row + 1
Rows(a & ":" & a).Insert Shift:=xlDown, CopyOrigin:=1
cell.Offset(1, 0).Value = cell.Value
cell.Offset(1, 0).Font.Size = "11"
cell.Clear
End If
Next
End Sub
This sounds like a very basic question (and it is), but I cannot figure it out and I cannot find a suitable solution on the web.
How do you select the last cell in a column that contains a numeric value and delete it?
I have formulas that go past this cell and return blank values in the column. This is what is tripping me up at the moment. My current code will go all the way down to where I have carried the formulas to and start deleting those cells instead of deleting the last cell with a numeric value.
My current code looks like this
Range("AA1500").End(xlUp).Select
With Selection.Delete
End With
Any help would be greatly appreciated.
Please let me know if I can clarify anything.
Thanks
If you want to go down past cells with arbitrary strings in them and
delete the last numeric value (but not the last cell with a alphanumeric string in it), this should work:
Sub deleteLastNum()
Dim row As Integer
row = Range("A1000").End(xlUp).row
For i = row To 1 Step -1:
If IsNumeric(Cells(i, "A")) Then
Cells(i, "A").Clear
Range("A" & CStr(i + 1), "A" & CStr(row)).Cut Destination:=Range("A" & CStr(i))
Exit For
End If
Next
End Sub
It will also delete the last cell with a formula that evaluates to a number. It moves down the range of cells in the column above it with characters in it to fill in the cleared cell.
What you can do is get the total number of rows of a column (A) then check is last cell value is numeric or not, if numeric then clear that cell.
Sub del()
Dim sh As Worksheet
Dim rn As Range
Set sh = ThisWorkbook.Sheets("Sheet1")
Dim k As Long
Set rn = sh.UsedRange
k = rn.Rows.Count + rn.Row - 1
If IsNumeric(Sheets("Sheet1").Range("A" & k).Value) = True Then
Sheets("Sheet1").Range("A" & k).ClearContents
End If
End Sub
This will check last cell for numeric value in column A.
Hope this is what you are asking.
EDIT
Implementing above for all the sheets in a workbook using a loop is like :
Sub del()
Dim sh As Worksheet
Dim rn As Range
For Each sh In ActiveWorkbook.Worksheets
Set sh = ThisWorkbook.Sheets(sh.Name)
Dim k As Long
Set rn = sh.UsedRange
k = rn.Rows.Count + rn.Row - 1
If IsNumeric(sh.Range("A" & k).Value) = True Then
sh.Range("A" & k).ClearContents
End If
Next sh
End Sub
This will loop through each sheet like Sheet1, Sheet2 or whatever the name of the sheet may be and check for numeric value in last cell of col A, if found numeric then it will delete the value.
You already got an answer to your post, just to be clear, the safest way to find the last row (let's say in Column "AA", according to your post), and ignoring blank cells in the middle, is by using the syntax below:
Sub FindlastRow()
Dim LastRow As Long
With Worksheets("Sheet1") ' <-- change "Sheet1" to your sheet's name
LastRow = .Cells(.Rows.Count, "AA").End(xlUp).Row
' rest of your coding here
End With
End Sub
Screen-shot of the result:
Use 'SpecialCells()'
Sub ClearLastNumber(sh As WorkSheet, columnIndex As String)
On Error GoTo ExitSub 'should 'columnIndex' column of 'sh' worksheet contain no numbers then the subsequent statement would throw an error
With sh.Columns(columnIndex).SpecialCells(xlCellTypeConstants, xlNumbers)
With .Areas(.Areas.Count)
.Cells(.Count).ClearContents
End With
End With
ExitSub:
End Sub
To be used in your "main" sub as follows
Sub Main()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
ClearLastNumber Sh "A"
Next
End Sub
I have a VBA Excel code with that checks values in a specific column. If the row in that column contains the value 'Delete' and then deletes the row.
The code works well, but it is really slow. Any ideas on how to get the code run faster?
Dim rng1 As Range
Dim i As Integer, counter As Integer
'Set the range to evaluate to rng.
Set rng1 = Range("g1:g1000")
'initialize i to 1
i = 1
'Loop for a count of 1 to the number of rows
'in the range that you want to evaluate.
For counter = 1 To rng1.Rows.Count
'If cell i in the range1 contains an "Delete"
'delete the row.
'Else increment i
If rng1.Cells(i) = "Delete" Then
rng1.Cells(i).EntireRow.Delete
Else
i = i + 1
End If
Next
Thanks
c.
Sub deletingroutine()
Dim r As Range
For Each r In Range("g1:g1000")
If r = "delete" Then r.EntireRow.Delete
Next r
End Sub
I managed to find a solution with the Autofilter function.
Hope it helps someone
Selection.AutoFilter
Set ws = ActiveWorkbook.Sheets("UploadSummary")
lastRow = ws.Range("G" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("G1:G" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=7, Criteria1:="delete" ' 7 refers to the 7th column
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Try sorting the rows (on collumn G) then deleting all marked ("delete") rows in one action. That is much faster.