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").)
Related
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
I'm working on having a production schedule sort due dates into different worksheets from a data dump sheet. I can get it working for one date manually, but I'd like it to loop for the entire range. When I try to loop it it gets stuck, I think it's because I'm deleting and shifting cells up in the groupBy sub.
Sub groupByDate()
'matches every date to the first cell, copies them onto a new sheet
'then deletes original range and shifts up for new top date
Dim day As Range
Dim due As Range
Set due = Range(Range("D29"), Range("D29").End(xlDown))
Dim cel As Range
For Each cel In due
'appends the range to move, if empty create range to move
If (cel.Value = due.Cells(1).Value) Then
If day1 Is Nothing Then
Set day = cel.EntireRow
Else
Set day = Union(day, cel.EntireRow)
End If
End If
Next
day.Copy
Sheets.Add.PasteSpecial
day.Delete Shift:=xlUp
End Sub
Here is my loop function:
Sub testLoop()
'trying to loop groupBy until dump range is empty
Dim cel As Range
Set cel = Range("D29")
Do While True
If cel.Value <> "" Then
groupByDate
Else
Exit Do
End If
Loop
End Sub
When you have one date Range("D29").End(xlDown) could be D1048576. Also the new sheet will become the active sheet and on second pass of loop after row 29 is deleted cel is undefined and needs to be reassigned with a next value.
Sub groupByDate()
'matches every date to the first cell, copies them onto a new sheet
'then deletes original range and shifts up for new top date
Dim day As Range, ue As Range, cel As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Set due = ws.Range(ws.Range("D29"), ws.Range("D29").End(xlDown))
If due.Rows.Count > 1000000 Then Set due = ws.Range("D29") ' single date
For Each cel In due
'appends the range to move, if empty create range to move
If (cel.Value = due.Cells(1).Value) Then
If day Is Nothing Then
Set day = cel.EntireRow
Else
Set day = Union(day, cel.EntireRow)
End If
End If
Next
day.Copy
Sheets.Add.PasteSpecial
day.Delete Shift:=xlUp
ws.Activate ' return to active sheet
End Sub
Sub testLoop()
'trying to loop groupBy until dump range is empty
Dim cel As Range
Set cel = Range("D29")
Do While cel.Value <> ""
groupByDate0
Set cel = Range("D29")
Loop
End Sub
I am trying to give the user the option to do simple arithmetic operations on selected cells.
The thing is that most cells are merged ranges.
I got the following already but the problem with it is that it loops through all cells while I only want it to only affect those cells that are not merged or only to the first cells of merged ranges.
Sub test()
Application.ScreenUpdating = False
Dim cel As Range
Dim selectedRange As Range
myValue = InputBox("Enter")
Set selectedRange = Application.Selection
For Each cel In selectedRange.Cells
On Error Resume Next
cel.Value = Evaluate(cel.Value & myValue)
Next cel
End Sub
Although VBasic2008's answer works, it's not totally correct. The problem is that each cell in merged range always returns True for MergedCells property. This means that excessive processing is done in a loop (i.e. incrementing a value) for cells other than top-left cell. To fix this situation, you should test each cell for the need to process. You can do this in several ways:
You can compare the address of a cell with the top-left cell address (Option 1 in code).
You can test the length of cell's value. If it's zero, then it's not top-left cell, so you skip it (Option 2 in code).
Code:
Sub IncrValues()
Dim rng As Range, myValue%
myValue = InputBox("Enter")
For Each cell In Selection
If cell.MergeCells Then
'// Option 1:
If cell.Address = cell.MergeArea(1).Address Then
cell.Value = cell.Value + myValue
End If
'// Option 2:
'If Len(cell) > 0 Then
' cell.Value = cell.Value + myValue
'End If
Else
cell.Value = cell.Value + myValue
End If
Next
End Sub
The MergeCells Property
Using the MergeCells property in an If statement, you check if a cell is not merged, then execute the following statement(s), otherwise the statement(s) after Else.
In the following example, the range I3:M12 is selected and 5 is entered as myValue. The first table is the state of the second table before.
The Code
Sub test()
Dim cel As Range
Dim selectedRange As Range
Dim myValue As Double
Application.ScreenUpdating = False
myValue = InputBox("Enter")
Set selectedRange = Application.Selection
For Each cel In selectedRange.Cells
If Not cel.MergeCells Then
' If not merged cell.
cel.Value = Evaluate(cel.Value & myValue)
Else
' if merged cell.
cel.Value = Evaluate(cel.Value + myValue)
End If
Next cel
Application.ScreenUpdating = True
End Sub
Count
We can expand the previous tables by adding a COUNT column,
where it is more obvious how the merged cells are being 'ignored' in Excel i.e. all cells except the first cell of a merged area will not be counted (or summed up, or ...).
The following shows the difference between counting the cells in VBA and in Excel.
Sub MergeTest()
With Range("J3:J12")
Debug.Print .Cells.Count
Debug.Print WorksheetFunction.Count(.Cells)
End With
With Range("J3:N12")
Debug.Print .Cells.Count
Debug.Print WorksheetFunction.Count(.Cells)
End With
End Sub
The results in the Immediate window are
10,
9,
50,
46,
which shows how VBA will count every cell, but Excel will exclude all cells of a merged area except the first.
In VBA Help search for the MergeArea property for some further info.
Hello!
I am trying to build a code that loops through each cell in range C8:C3276 and inserts a new row below if the cell value is "Total".
Here is the code i have so far:
Sub Create_new_rows()
Dim rng As Range
Dim cell As Range
Set rng = Range("C8:C3276")
For Each cell In rng
If ActiveCell.Value = "Total" Then
ActiveCell.Offset(1, 0).Activate
ActiveCell.EntireRow.Insert
End If
Next cell
End Sub
Nothing happens when i execute the code. I assume the code is built incorrectly as the macro runs (i get no error message), but without doing anything.
Any help is greatly appreciated! :)
Two problems I think. 1) You should loop backwards as otherwise you will skip rows as you are adding more rows, and 2) in your loop you should have referred to cell rather than the ActiveCell which is never set.
Sub Create_new_rows()
Dim rng As Range, r As Long
Set rng = Range("C8:C3276")
For r = rng.Count To 1 Step -1
If rng(r).Value = "Total" Then
rng(r + 1).EntireRow.Insert
End If
Next r
End Sub
I have an excel file like
Original File
I want to transform all the cells that filled with information into a single column. Like
To transform This
How to i do this ?
I searched in internet about that i found just only transform cells in a single row to a single cell. But i couldn't find anything like this. Can you help me about that
This is a bit of code I keep around for this kind of job. It assumes that the values in each row are contiguous, that is there are no blank cells inside the data set. It also assumes that you're on the sheet that contains the data when you trigger it, and that you want the data to be placed on a new worksheet.
Option Explicit
Sub Columnise()
Dim shtSource As Worksheet
Dim shtTarget As Worksheet
Dim rngRow As Range, rngCol As Range
Dim lCount As Long
Set shtSource = ActiveSheet 'Or specify a sheet using Sheets(<name>)
Set rngCol = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set shtTarget = Sheets.Add 'Or specify a sheet using Sheets(<name>)
'Define starting row for the data
lCount = 1
'Loop through each row
For Each rngRow In rngCol
'On each row, loop through all cells until a blank is encountered
Do While rngRow.Value <> ""
'Copy the value to the target
shtTarget.Range("A" & lCount).Value = rngRow.Value
'Move one space to the right
Set rngRow = rngRow.Offset(0, 1)
'Increment counter
lCount = lCount + 1
Loop
Next rngRow
End Sub
You should end up with all the data in a single column on a new worksheet.
EDITED TO ADD: Since you mentioned your data does contain blank cells, it gets more complicated. We'll want to add a way to continue to the actual end of the data, rather than just looping until we hit a blank cell. We'll modify the Do While... condition to this:
Do While rngCell.Column <= Cells(rngCell.Row, Columns.Count).End(xlToLeft).Column
This will loop until the end of the data in the row, then move on. Give it a shot and let us know.