I want to find cells, which contain an exact value and insert in front of those cells blank rows. I already have code, which will find and insert those rows, but only behind those cells.
The code is here:
Private Sub SearchnInsertRows()
Dim LastRow As Long
Dim rng As Range, C As Range
Dim vR(), n As Long
With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched
' loop through all cells in column A and copy below's cell to sheet "Output_2"
For Each C In rng
If C.Value = "Workflow" Then
.Range(Cells(C.Row + 1, 1), Cells(C.Row + 8, 8)).EntireRow.Insert
End If
Next C
End With
End Sub
This code will add 8 rows behind all cells, which contain word "Workflow", but I cannot figure it out, how to put them in front of cells "Workflow"
I thought, that when I put - instead of +, it should solve it, but when I change this line this way:
.Range(Cells(C.Row - 1, 1), Cells(C.Row - 8, 8)).EntireRow.Insert
and run it, the excel will stuck and still adding rows.
Could I ask you for an advice, what do I do incorrectly, please?
Many thanks
Instead of an For Each loop use a For i = LastRow to 1 Step -1 loop to loop backwards from last row to first. Inserting or deleting rows has always to be done backwards (from bottom to top) because then it will only affect rows that are already processed otherwise the row-counts of unprocessed rows will change and mess up the loop.
Something like the following should work:
Option Explicit 'Very first line in a module to enforce correct variable declaring.
Private Sub SearchAndInsertRows()
Dim lRow As Long, iRow As Long
With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
'loop backwards (bottom to top = Step -1) through all rows
For iRow = lRow To 1 Step -1
'check if column A of current row (iRow) is "Workflow"
If .Cells(iRow, "A").Value = "Workflow" Then
.Rows(iRow).Resize(RowSize:=8).Insert xlShiftDown
'insert 8 rows and move current (iRow) row down (xlShiftDown)
'means: insert 8 rows ABOVE current row (iRow)
'.Rows(iRow + 1).Resize(RowSize:=8).Insert xlShiftDown
'alternatively use .Rows(iRow + 1) to insert BELOW current row (iRow)
End If
Next iRow
End With
End Sub
Related
I'm trying to write some code that will delete any row where the character "," or Chr(44) is not found in any of the cells in that row.
I've gotten this far but am struggling because the code is only searching column C for "," but I need it to search the entire current row.
How can I get this updated?
Sub DeleteRows()
' Defines variables
Dim Cell As Range, cRange As Range, LastRow As Long, x As Long
' Defines LastRow as the last row of data based on column C
LastRow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).row
' Sets check range as C1 to the last row of C
Set cRange = Range("C1:C" & LastRow)
' For each cell in the check range, working from the bottom upwards
For x = cRange.Cells.Count To 1 Step -1
With cRange.Cells(x)
' If the cell does not contain one of the listed values then...
If .value <> "Chr(44)" Then
' Delete that row
.EntireRow.Delete
End If
End With
' Check next cell, working upwards
Next x
End Sub
Probably easier to use the Find method of Range object, rather than doing cell-by-cell iteration. And you can use the EntireRow property of each cell Range to do this:
For x = cRange.Cells.Count To 1 Step -1
With cRange.Cells(x).EntireRow
If .Find(Chr(44)) Is Nothing Then
.Delete
End If
End With
Next
Also note per John's comment on OP, you were (mistakenly) comparing against a string literal "Chr(44)" when you need to be comparing against the evaluation of Chr(44) function, which returns a string: ",".
I need to check each cell in row 7 starting from C7 (C7, D7, E7, etc) and find a cell with a string value that contains a certain date (for example, "9/30/2017" in string "6/30/2017 to 9/30/2017") and delete ALL columns from column C to whatever column that the cell is in. How would I do this with VBA code? I am new to VBA and have tried everything that I could find. Thankful for any suggestions
My code:
Sub DeleteUnnecessaryColumns(specifiedWorksheet)
Dim lastCol As Long
lastCol = Cells.Find(What:="*", After:=[C1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
For i = 1 To lastCol
If InStr(Cells(7, 0), specifiedDate, vbTextCompare) = 0 Then
Columns(i).Delete
End If
Next i
End Sub
A few changes:
Use a With block to explicitly target the specified worksheet
Add a . before the Cells collection to explicitly link to the specified worksheet (through the With block)
Start the loop with the correct column index for Column C = 3 (For i = 3 ...)
You missed the first argument to the InStr function: starting character (1 was assumed) MSDN
The second argument for InStr wasn't set to the i variable. This will now cycle through the values in each column
The loop would not stop once it found the search text. So I added an Else clause that exits the For loop once specifiedDate is found, preventing the script from deleting columns to the right of the target column.
specifiedDate was never passed to the Sub or declared so I added it as a parameter. You can also declare and set it within this procedure. If it's declared as a public variable, then delete the parameter.
The .Find method is only available to a range object, so I used a method available to cells instead
After a column is deleted, the indices for the remaining columns are reduced by one so the same must be done to the variables controlling the loop
It should now properly delete a column if the search text is not found in row 7 and will stop executing once the first match is found, leaving the remaining columns intact.
Sub DeleteUnnecessaryColumns(specifiedWorksheet, specifiedDate)
Dim lastCol As Long
With specifiedWorksheet
lastCol = .Cells(7, .Columns.Count).End(xlToLeft).Column
For i = 3 To lastCol
If InStr(1, .Cells(7, i), specifiedDate, vbTextCompare) = 0 Then
.Columns(i).Delete
i = i - 1
lastCol = lastCol - 1
Else
Exit For
End If
Next i
End With
End Sub
Something like... You need to call it from somewhere else, using syntax like DeleteUnnecessaryColumns "Sheet1", "9/30/2017"
Sub DeleteUnnecessaryColumns(specifiedWorksheet as worksheet, SpecifiedDate as string)
dim r as range ' set up a range for row 7, columns C to the end
set r = specifiedWorksheet.rows(7)
set r = r.resize(Columnsize:= r.columns.count - 2)
set r = r.offset(0,2)
Dim lastCol As Long, i as long
for i = 1 to r.columns.count 'loop through the cells in the r range
if instr(string:=r.cells(i), substring:= SpecifiedDate) > 0 then
lastcol = i 'this ends the loop and sets the value for lastcol
end if
next
SpecifiedWorksheet.range(cells(1, 3), cells(1, lastcol - 1).entirecolumn.delete
End Sub
I am working on a code and all I want to do is copy data from one sheet and paste it into another sheet that has a table setup.
My code is doing exactly what I want it to do but, the table doesn't resize to include all the rows that was copied, only the first row of the copied data goes into the table. and the rest are formatted as not in the table.
This is how it looks like after I run the code
Sub LastRowInOneColumn()
Dim LastRow As Longenter image description here
Dim i As Long, j As Long
'Find the last used row in a Column
With Worksheets("First Page")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Report")
j = .Cells(.Rows.Count, "A").End(xlUp).Row '+ 1
End With
For i = 1 To LastRow
With Worksheets("First Page")
'If .Cells(i, 1).Value = "X" Then
.Rows(i).Copy Destination:=Worksheets("Report").range("A" & j)
j = j + 1
'End If
End With
Next i
End Sub
Usually, inserting below the end of the table will make it grow automatically, but not when pasting a range that exceeds the number of columns in the table. There are two ways to deal with this:
1- limit the copied range to the number of columns in the table; i.e.
.Rows(i).Resize(,4).Copy Destination:=Worksheets("Report").range("A" & j)
' ^^^^^^^^^^^
2- Explicitly resizing the table, using the method ListObject.Resize; i.e.
With Sheet1.ListObjects(1)
.Resize .Range.Resize(.Range.Rows.count + 1)
End With
I'm trying to copy an entire row by index number and paste it to another row with a different index number when a certain condition is met (I know the issue is not with the conditional logic). I'm thinking of something like this:
Sub Makro1()
Dim i As Integer
With ActiveSheet
'for looping
totalRows = .Cells(.Rows.Count, "A").End(xlUp).Row
'index of last row even after rows have been added
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'data starts at row #3
For i = 3 To totalRows
If .Cells(i, 19).Value > 0 Then
Number = .Cells(i, 19).Value
Do While Number > 0
lastRow = lasRow + 1
'Next line doesnt do anything
.Rows(lastRow) = .Rows(i).Value
Number = Number - 1
Loop
End If
Next i
End With
End Sub
The logic works like its supposed to but no lines are pasted. I've gone step by step and am certain the problem is not with the logic.
I assume that you want to copy Rows(i) and paste it as value in Rows(lastRow). So, you need to replace this line
.Rows(lastRow) = .Rows(i).Value
with these two lines:
.Rows(i).Copy
.Rows(lastRow).PasteSpecial xlPasteValues
Or
.Rows(lastRow).Copy
.Rows(i).PasteSpecial xlPasteValues
if you want to copy Rows(lastRow) and paste it as value in Rows(i).
Edit:
To paste everything (formulas + values + formats), use paste type as xlPasteAll.
Reference: msdn
Range Copy and Paste
Syntax
Range().Copy [Destination]
The square brackets indicate that Destination is an optional parameter. If you don't designate a Destination range it copies the selection to the clipboard. Otherwise it copies the first range directly to the new location.
Change this line:
.Rows(lastRow) = .Rows(i).Value
To:
.Rows(lastRow).copy .Rows(i)
It's worth noting that
.Rows(lastRow).copy .Cells(i, 1)
Will also work. Excel will resize the Destination range to fit the new data.
your code works for me
so just add a breakpoint at .Rows(lastRow) = .Rows(i).Value statement and then query all relevant variables value in the Immediate Window, like:
?lastRow
?.Rows(lastRow).Address
?i
?.Rows(i).Address
in the meanwhile you could
add Option Explicit statement at the very top of your code module
this will force you to declare all variables and thus lead to some extra work, but you'll get repaid with much more control over your variables usage and misspelling, thus saving debugging time
dim variables to hold rows index as of Long type, to handle rows index higher then 32767
avoid inner loop using the Resize() method of range object
much like follows:
Option Explicit
Sub Makro1()
Dim i As Long, totalRows As Long, lastRow As Long, Number As Long
With ActiveSheet
'for looping
totalRows = .Cells(.Rows.Count, "A").End(xlUp).Row
'index of row to add from
lastRow = totalRows + 1 '<--| start pasting values one row below the last non empty one in column "A"
'data starts at row #3
For i = 3 To totalRows
If .Cells(i, 19).Value > 0 Then
Number = .Cells(i, 19).Value
.Rows(lastRow).Resize(Number).Value = .Rows(i).Value
lastRow = lastRow + Number
End If
Next i
End With
End Sub
I have the following column (1):
1
15
150
1500000
06700
07290
07500
2
22
220
2200000
00900
This would need to become 2 columns
1
15
150
1500000 06700
1500000 07290
1500000 07500
2
22
220
2200000 00900
My initial idea:
Create the extra column.
Looping through the rows, register the cell and value in variables when a number with lenght of 7 digits is found.
Move the values under it to column B until the lenght of values is <> 5
Start from cell saved in variable and copy value from variable to column A until column A is no longer Empty
After the above proces, loop rows and delete where A is lenght 7 and B is empty.
As i am not familiar with VBA, before i plunge into, i would like to verify this above set of rules would do what i intend it to do, if it's technically feasable with VBA macro's and wether or not it could result to unexpected behaviour.
This code would have to run every month on a new large excel file.
Whether your 5 digit (c/w/ leading zeroes) numbers are true numbers with a cell formatting of 00000 or text-that-look-like-numbers with a Range.PrefixCharacter property, the Range.Text property should be able to determine their trimmed length from the displayed text.
The following code follows your logic steps with a few modifications; the most obvious one is that it walks from the bottom of column A to the top. This is to avoid skipping rows that have been deleted.
Sub bringOver()
Dim rw As Long, v As Long, vVAL5s As Variant, vREV5s As Variant
'put the cursor anywhere in here and start tapping F8
'it will help if you can also see the worksheet with your
'sample data
ReDim vVAL5s(0) 'preset some space for the first value
With Worksheets("Sheet1") '<~~ set this worksheet reference properly!
'ensure a blank column B
.Columns(2).Insert
'work from the bottom to the top when deleting rows
'or you risk skipping a row
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
'determine the length of the trimmed displayed length
'and act accordingly
Select Case Len(Trim(.Cells(rw, 1).Text))
Case Is < 5
'do nothing
Case 5
'it's one to be transferred; collect it
vVAL5s(UBound(vVAL5s)) = .Cells(rw, 1).Text
'make room for the next
ReDim Preserve vVAL5s(UBound(vVAL5s) + 1)
Case 7
'only process the transfer if there is something to transfer
If CBool(UBound(vVAL5s)) Then
'the array was built from the bottom to the top
'so reverse the order in the array
ReDim vREV5s(UBound(vVAL5s) - 1)
For v = UBound(vVAL5s) - 1 To LBound(vVAL5s) Step -1
vREV5s(UBound(vREV5s) - v) = vVAL5s(v)
Next v
'working With Cells is like selecting htem but without selecting them
'want to work With a group of cells tall enough for all the collected values
With .Cells(rw, 1).Resize(UBound(vREV5s) + 1, 1)
'move over to column B and put the values in
.Offset(0, 1) = Application.Transpose(vREV5s)
'make sure they show leading zeroes
.Offset(0, 1).NumberFormat = "[Color13]00000;[Color9]#"
'if there was more than 1 moved over, FillDown the 7-wide value
If CBool(UBound(vREV5s)) Then .FillDown
'delete the last row
.Cells(.Rows.Count + 1, 1).EntireRow.Delete
End With
'reset the array for the next first value
ReDim vVAL5s(0)
End If
Case Else
'do nothing
End Select
'move to the next row up and continue
Next rw
'covert the formatted numbers to text
Call makeText(.Columns(2))
End With
End Sub
Sub makeText(rng As Range)
Dim tCell As Range
For Each tCell In rng.SpecialCells(xlCellTypeConstants, xlNumbers)
tCell.Value = Format(tCell.Value2, "\'00000;#")
Next tCell
End Sub
Just before exiting the primary routine, the short helper sub is called using column B as a range of cells. This will loop through all of the numbers in column B and convert the numbers into text with leading zeroes.
As noted in the code comments, set yourself up so you can see the code sheet as well as a portion of your worksheet and start tapping F8 to step through the code. I've tried to add a form of running commentary with the notes left above many of the code lines.
After writing the logic keeping in mind Jeeped's input i ended up making it the following way:
Force convert the column A to definately be Text
Create the extra column.
Get the number of rows with data
Loop 1: If column A cell lenght is 5, move cell to column B
Loop 2: If column A cell lenght is 7, we copy the value to variable.
Loop 2: If column A cell lenght is 0, we paste variable to the cell
After the above proces, loop rows and delete where A is lenght 7 and B is empty. (reverse loop for performance)
All input on the below posted code is more than welcome. I'm open for every kind of possible optimization.
Sub FixCols()
'First trim the numbers (text) with 2 methods. VBA trim and Worksheet formula trim
Range("A:A").NumberFormat = "#"
Dim Cell As Range
For Each Cell In ActiveSheet.UsedRange.Columns("A").Cells
x = x + 1
Cell = Trim(Cell)
Cell.Value = WorksheetFunction.Trim(Cell.Value)
Next
'Now insert empty column as B
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Determine rows with values for loop
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Loops to move around the data
Dim i As Long
Dim CellValue As Long
For i = 1 To LastRow
'move items to column B
If Len(Range("A" & i).Value) = 5 Then
Range("A" & i).Select
Selection.Cut
Range("B" & i).Select
ActiveSheet.Paste
End If
Next i
For i = 1 To LastRow
'if the row is a reknr we copy the value
If Len(Range("A" & i).Value) = 7 Then
CellValue = Range("A" & i).Value
End If
'Paste the reknr to the rows with item
If Len(Range("A" & i).Value) = 0 Then
Range("A" & i).Value = CellValue
End If
Next i
'Reverse loop (performance) to check for rows to delete (reknr without item)
i = LastRow
Do
If Len(Range("A" & i).Value) = 7 And Len(Range("B" & i).Value) = 0 Then
Rows(i).Delete
End If
i = i - 1
Loop While Not i < 1
End Sub