This code works but I feel there could be a better way.
Starting from cell AL2, I go through each column until I find the first empty cell in row 2.
Then, I insert a new column left to that empty cell.
Finding the empty cell is almost instant but it takes around 15-20 seconds to insert a new column.
Range("AL2").Select
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Select
Loop
ActiveCell.EntireColumn.Insert
Do not use .Select and instead of looping and testing every cell you can just use StartCell.End(xlToRight) to jump right to last used cell.
Option Explicit
Public Sub InsertColumn_Example()
Dim ws As Worksheet
Set ws = ActiveSheet ' better define your worksheet like `Set ws =ThisWorkbook.Worksheets("Sheet1")
' find next empty cell in the row of StartCell
Dim NextEmptyCell As Range
Set NextEmptyCell = GetNextEmptyCellByColumn(StartCell:=ws.Range("AL2"))
' insert column
NextEmptyCell.EntireColumn.Insert
End Sub
Public Function GetNextEmptyCellByColumn(ByVal StartCell As Range) As Range
If IsEmpty(StartCell) Then
' if StartCell cell is empty return it
Set GetNextEmptyCellByColumn = StartCell
ElseIf IsEmpty(StartCell.Offset(ColumnOffset:=1)) Then
' if cell right of StartCell is empty return it
Set GetNextEmptyCellByColumn = StartCell.Offset(ColumnOffset:=1)
Else
' otherwise jump to the next empty cell right of StartCell
Set GetNextEmptyCellByColumn = StartCell.End(xlToRight).Offset(ColumnOffset:=1)
End If
End Function
Related
I'm trying to build a VBA application that checks for a certain value, then adds a row on top for each time this value is found.
Sub copy()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("B2:B10")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.value = "test" Then
MsgBox "found" + cell.Address
cell.EntireRow.Insert
End If
Next cell
Next row
End Sub
Every time I try to run this function, however, it keeps adding rows on top of each other continuously and not for each occurrence.
If you loop the cells from top to bottom, adding the row will push your original range down, causing the next loop to evaluate the previous cell.
To avoid this, loop backwards (i.e. bottom to top):
Sub copy_test()
Dim rng As Range
Set rng = Range("B2:B10")
Dim i As Long
For i = rng.Cells.Count To 1 Step -1
If rng.Cells(i).Value = "test" Then
Debug.Print "Found"
rng.Cells(i).EntireRow.Insert
End If
Next i
End Sub
Note: Set rng = Range("B2:B10") is telling VBA that you are referring to Cells B2:B10 of the ActiveSheet which might not be what you want.
Please fully qualify your range to avoid this. (e.g. ThisWorkBook.Worksheets("Sheet1").Range("B2:B10") or use the code name of the worksheet Sheet1.Range("B2:B10").)
I am trying to write a macro that tidies up and interrogates raw data exported from some analytical instrumentation. I would like it to look through one column (sample names) down all rows and look for indicators of specific sample types e.g. duplicates. Finding these indicators I want to insert a row, and in the new inserted row do some simple calculations based on the two rows above. For now I will just be happy getting the row insertion to work.
I can get it to find the key word and insert 1 row, but it finds the first one and stops. There are multiple instances of these keywords in my data, and i want to insert a row below each
'original code - finds first keyword, inserts row and stops
Sub dup_finder()
Dim colHeader As Range
Set colHeader = Range("B1:B500")
Dim currCell As Range
Set currCell = Cells.Find("*_dup")
If Not currCell Is Nothing Then currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
End Sub
'my attempt to include loop - inserts 500 rows below keyword! stops
after first instance
Sub dup_finder()
Dim colHeader As Range
Dim row As Long
Dim currCell As Range
Set colHeader = Range("B1:B500")
Set currCell = Cells.Find("_dup")
For row = 1 To 500
If Not currCell Is Nothing Then currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Next row
End Sub
I suggest always fully qualifying your ranges with the workbook and sheet.
You should be able to adapt this to what you want. You simply enter the range you want to check in, and the value you are checking for.
It works backwards, up through the range, inserting a row below each one it finds.
Sub InsertRows()
''Declare your variables
Dim RngToCheck As Range, ValToFind As String
''Set the range in which to look for your desired string.
Set RngToCheck = ThisWorkbook.Sheets("Sheet1").Range("B1:B500")
''Set what string to look for.
ValToFind = "_dup"
''Declare a variable to use as a counter
Dim i As Long
''Count backwards through each of the rows in the range.
''(If you went forwards through the range, the rows you
''are inserting would become part of that range and push
''the bottom rows (which you intended to check) out of the range).
For i = RngToCheck.Rows.Count To 1 Step -1
''Check if the last characters (the number of characters to
''check is defined by the length of the string we are looking
''for) of the current cell match the string we are looking for.
If Right(RngToCheck(i).Value, Len(ValToFind)) = ValToFind Then
''Insert the row (we need to offset by 1 row
''because rows are inserted ABOVE, and we
''want it BELOW the current cell).
RngToCheck(i).Offset(1, 0).EntireRow.Insert
''Now you can add your formulas to the new row...
''column A
RngToCheck(i).Offset(1, -1).Formula = "=1+1"
''column B
RngToCheck(i).Offset(1, 0).Formula = "=2+2"
''column C
RngToCheck(i).Offset(1, 1).Formula = "=A" & RngToCheck(i).Offset(1, 1).Row & "+B" & RngToCheck(i).Offset(1, 1).Row
''column D
RngToCheck(i).Offset(1, 2).Formula = "Hello"
''And so on...
End If
Next i
End Sub
Assuming you do want to insert a row under every instance of a cell in column B containing "_dup" this should work.
The problem with your code was that it wasn't looping and so only ever found one instance.
It's advisable not to specify a fixed range as you are inserting rows and the range will expand; however, you could do this and set the search direction as "previous".
Sub dup_finder()
Dim colHeader As Range, s As String
Set colHeader = Range("B1:B500") ' not actually used
Dim currCell As Range
'are we searching just B or the whole sheet?
Set currCell = Columns(2).Find(What:="_dup", Lookat:=xlPart, MatchCase:=False, SearchFormat:=False) 'change parameters to suit
If Not currCell Is Nothing Then
s = currCell.Address 'store address of first found cell
Do
currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Set currCell = Columns(2).FindNext(currCell) 'find next case
Loop Until currCell.Address = s 'keep looping until we are back to the original case
End If
End Sub
I am very new to VBA in excel and I have recorded and modified a macro that gets a value then based on an "IF" statement it uses the answer to calculate a value in a certain cell . I need to repeat this until there is a blank cell in column A.
My Data is
Part Number reported actual waste in the first 4 columns here follows my code that I need to repeat until column A is blank.
Sub MissingMix()
'
' MissingMix Macro
' Calculates Missing Mix based on scrap
'
' Keyboard Shortcut: Ctrl+q
Application.Goto Reference:="R1C1"
Application.Goto Reference:="R3C8"
ActiveCell.FormulaR1C1 = "=IF(RC[-5]-RC[-6]>0,SUM(RC[-5]-RC[-6])*RC[+1],"""")"
Application.Goto Reference:="R3C9"
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-8],'QAD Weights'!RC[-8]:R[37]C[-5],4)"
End Sub
use this:
' get active sheet
Dim CurrentSheet As Worksheet
Set CurrentSheet = ActiveWorkbook.ActiveSheet
' defining starting row
Dim Values As Range
Set Values = Rows(5)
For i = 2 To Values.Cells.Count - 1
If Values.Cells(i).Text <> "" Then
' Do Something ...
End If
Next
you can also do the check with If Not IsEmpty(Cells(i).Value) Then ...
EDIT
There is another way that you can handle this.
Dim CurrentSheet As Worksheet
Set CurrentSheet = ActiveWorkbook.ActiveSheet
' getting the lastrow by jumping to the last filled row of cell(1,1)
' cell(1,1) means the cell at row=1 and column=1 (column "A")
Dim LastRow As Long
LastRow = CurrentSheet.Cells(1, 1).End(xlDown).Row
MsgBox LastRow
Here's what I have:
Response Flow
I have one sheet called Response Flow that has Response, Y/N and a Total. If the Response has a Y next to it I want to match the Response Name with the Response Name on Sheet 2 ("Campaigns") and insert a formula in the column next to the response name on Sheet 2 using VBA code. Below is what I have so far.
Sub Volume_Calc()
Dim LastRowR As Long
Dim LastRowC As Long
Dim LastRowI As Long
Dim LastRowA As Long
Dim rngFoundCell As Range
Dim cell As Range
Dim text As String
Dim FindRow As Range
LastRowR = Range("C65536").End(xlUp).Row
LastRowC = Range("K65536").End(xlUp).Row
LastRowI = Range("I65536").End(xlUp).Row
LastRowA = Range("A65536").End(xlUp).Row
Set FindRow = Worksheets("ResponseFlow").Range("C:C").Find(What:="Y",
LookIn:=xlValues)
Do While FindRow = True
If Application.Match(Worksheets("Campaigns").Range("K6"),
Worksheets("ResponseFlow").Range("A4:A" & LastRowA), 0) Then
Worksheets("Campaigns").Range("I6:I" & LastRowI).Formula = "=INDEX(ResponseFlow!$B$3:$B$145,MATCH(Campaigns!$K6,ResponseFlow!$A$3:$A$145,0))"
End If
Loop
End Sub
What you're intending to do seems like it'd be easier to do in Excel without VBA, but if you insist on having some macro insert formulas, this might be an easy approach. First put the dynamic formula you want to be pasting in to the right of the columns with a Y/N, SOMEWHERE in your sheet. In my example below I used Cell("Z1"). Make sure it's dynamic so that if you were to copy/paste formula into another cell, it would adjust correctly.
Again make sure whatever dynamic match formula you want to the right of your values is somewhere and configured to be dynamic. In my example it's on Response ws in cell Z1.
Sub Volume_Calc()
Dim Resp_WS As Worksheet: Set Resp_WS = Worksheets("ResponseFlow")
Dim CAMP_WS As Worksheet: Set CAMP_WS = Worksheets("Campaigns")
Dim rCell As Range
Dim cCell As Range
'Loops through Response Sheeet column "C" looking for values of "Y"
For Each rCell In Intersect(Resp_WS.Range("C:C"), WResp_WS.UsedRange).Cells
If UCase(rCell.Value) = "Y" Then
'When finds a cell with Y, it then loops through Campaigns Sheet column "I"
'looking for a value that matches one column to the left where the "Y" was found
For Each cCell In Intersect(CAMP_WS.UsedRange, CAMP_WS.Range("I:I")).Cells
'When match is found, the macro will insert the formula to the right
'of the cell in Campaigns, with the dynamically updated formula in cell Z1
If cCell.Value = rCell.offset(0,-1).Value Then
cCell.Offset(0, 1).FormulaR1C1 = Resp_WS.Range("Z1").FormulaR1C1
End If
Next cCell
End If
Next rCell
End Sub
I am trying to clear all the columns after the last header row
The macro runs but no clearing happens, I have played with the syntactic for awhile and am not getting it
Thanks
Sub ClearColumnsAfterLastHeader()
Dim ws As Excel.Worksheet
Dim hNames As Variant
Dim cell
Set ws = ActiveWorkbook.Sheets("Finished")
hNames = ws.Range("A1:R1").Value
For Each cell In hNames
If IsEmpty(cell) Then
cell.EntireColumn.ClearContents
End If
Next cell
End Sub
The main problem of your code is that hNames is array of Variant rather than Range and when you're looping through array For Each cell In hNames, variable cell refers to array element rather than to corresponding cell. So, you can't use cell.EntireColumn.ClearContents, because cell is not Range, but Variant.
As per my understanding of question, you want to determine last filled cell in first row (header row) and clear contents of all columns to the right of last filled header. In that case try code below:
Sub ClearColumnsAfterLastHeader()
Dim ws As Excel.Worksheet
Dim lastHeaderColumn As Long
Set ws = ActiveWorkbook.Sheets("Finished")
With ws
'determine last filled cell in first row
lastHeaderColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
'get of all cells to the right and down and clear contents
.Range(.Cells(1, lastHeaderColumn + 1), _
.Cells(.Rows.Count, .Columns.Count)).ClearContents
End With
End Sub
Cant you just do something like
Sub ClearStuff()
Dim ws As Worksheet
Dim LastCell As Range, ClearRange As Range
Set ws = ActiveWorkbook.Sheets("Finished")
Set LastCell = ws.Cells(1, ws.Columns.Count)
Set ClearRange = Range(LastCell.End(xlToLeft).Offset(0, 1), LastCell)
ClearRange.EntireColumn.ClearContents
End Sub