I have pretty limited knowledge of VBA so hopefully I can explain what I'm trying to do! I'm trying to copy a row if it has anything > 0 in column J.
I then want to insert this copied row into a new row bellow that copied cell.
I would like this to loop through the whole worksheet so that every row with a value in J is repeated, the data in the worksheet varies in size, there will always be a value in column B till the data ends...
Here's my failed attempt to far..
Sub Copy_Cells()
For Each Objcell In ActiveSheet.Columns(10).Cells
Do
If Objcell.Value > 0 Then
Objcell.EntireRow.Select
Selection.Copy
Selection.Insert Shift:=xlDown
Exit Sub
Loop Until IsEmpty(ActiveSheet.Columns(2).Cells)
End If
Next Objcell
End Sub
I think this is what you are trying to do.
Sub Copy_Cells()
botRow = 100
For i = botRow To 1 Step -1
If Cells(i, 10).Value > 0 Then
Rows(i).EntireRow.Copy
Rows(i + 1).Insert Shift:=xlDown
End If
Next i
End Sub
You would need to set the bottom row or you can implement a count of the used rows etc.
Sub Copy_Cells()
Dim totalRow as Integer
totalRow = Activesheet.Cells(1,2).End(xlDown).Row 'Count total row from B column
For Each Objcell In Activesheet.Range("J1:J" & totalRow)
If Objcell.Value > 0 Then
Objcell.EntireRow.Select
Selection.Copy
Selection.Insert Shift:=xlDown
End If
Next Objcell
End Sub
Related
I want to change the cell style based on the row number. I am still new on VBA.
Here is my code:
Sub format()
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To FinalRow
If Rows.Count = 2 * i + 1 Then
Selection.Style = "Good"
ElseIf Rows.Count = 2 * i Then
Selection.Style = "Bad"
End If
ActiveCell.Offset(1, 0).Select
Next i
End Sub
The loop moves to the next cell but does not highlight if a criteria is met. May you please help me.
I suggest the following:
Option Explicit
Public Sub FormatEvenOddRowNumbers()
Dim FinalRow As Long
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 1 To FinalRow
If i Mod 2 = 0 Then 'even row number
Cells(i, 1).Style = "Good"
Else 'odd row number
Cells(i, 1).Style = "Bad"
End If
Next i
End Sub
To test if a row number is "even" you can use If i Mod 2 = 0 Then also you don't need to test for "odd" because if it is not "even" it must be "odd" so you can just use Else without any criteria.
Try to avoid using .Select it makes your code slow. See How to avoid using Select in Excel VBA. Instead access the cells directly like Cells(row, column).
First, I think you missused Rows.Count.
Rows.Count returns the total number of rows of your sheet. So now your criteria is only highlighting the two rows that are in the middle of the sheet.
If I assume correctly that you want to put "Good" the Rows that are even and "bad" the ones that are odds. then you should change your code to something like this:
Sub format()
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To FinalRow
If i/2 = int(i/2) Then
Selection.Style = "Good"
ElseIf (i+1)/2 = int((i+1)/2) Then
Selection.Style = "Bad"
End If
ActiveCell.Offset(1, 0).Select
Next i
End Sub
as you can see I want to repeat it each time going to the next value... is there any easier way to do this?
I have tried the loop function but I don't know how to get this to work so that it executes to the next column each time for the same row.
Sub rebuild()
If D28 > 2600000 Then
Range("E$110:I$120").Select
Selection.Copy
Range("E18:Il28").Select
ActiveSheet.Paste
End If
If E28 > 2600000 Then
Range("E$110:I$120").Select
Selection.Copy
Range("F18:Jl28").Select
ActiveSheet.Paste
End If
If F28 > 2600000 Then
Range("E$110:I$120").Select
Selection.Copy
Range("G18:Kl28").Select
ActiveSheet.Paste
End If
If G28 > 2600000 Then
Range("E$110:I$120").Select
Selection.Copy
Range("H18:Ll28").Select
ActiveSheet.Paste
End If
End sub
It is really very simple. I have commented the code.
Also you do not need to select a range to copy/paste. You may want to see THIS
Sub rebuild()
With Sheet1 '~~> Change this to the relevant sheet
For i = 4 To 6 '<~~ Col 4 (D) to Col 6 (F)
If .Cells(28, i).Value > 2600000 Then
'~~> Increment the range wgere you want to paste
.Range("E$110:I$120").Copy .Range(.Cells(18, i + 1), .Cells(128, i + 5))
End If
Next i
End With
End Sub
A solution could be to put your variables into an array, and then make a simple for loop.
Dim MyArray(4, 2) as Variant
MyArray(0,0) = D28
MyArray(0,1) = Range("E18:Il28")
MyArray(1,0) = E28
MyArray(1,1) = Range("F18:Jl28")
MyArray(2,0) = F28
MyArray(2,1) = Range("G18:Kl28")
MyArray(3,0) = G28
MyArray(3,1) = Range("H18:Ll28")
For i = LBound(MyArray) to UBound(MyArray)
If MyArray(i,0) > 2600000 then
Range("E$110:I$120").Copy
MyArray(i,1).Paste
End If
Next
I am writing a script to fill down values of the column based on the column header/first value of the column. In this case, I want the script to identify all columns with the header "||" and fill down to the current region of the sheet.
I have the following but instead of filling down on all columns I want just columns with "||" in the header. Can a condition be a added in thewith statements? Or is there a better approach?
Sub FillCellsFromAbove()
Option Explicit
On Error Resume Next
With Columns
.SpecialCells(xlCellTypeBlanks).formula = "=R[-1]C"
.Value = .Value
End With
Err.Clear
End Sub
Screenshot of spreadsheet: Imgur: The most awesome images on the Internet
Also, the || columns varies. Sometimes there could be 3, other times it could be 6+
Sub FillCellsFromAbove()
Dim lColumn As Long, yes As Integer
lColumn = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To lColumn
yes = InStr(Cells(1, i).Value, "||")
If yes <> "0" Then
'Add code to fill in the column
End If
Next i
End Sub
Thanks, adapted your code and it's working so far.
For i = 1 To lColumn
yes = InStr(Cells(1, i).Value, "||")
If yes <> 0 Then
Set Filldown = Range(Cells(1, i), Cells(lrc, i))
Filldown.Select
Selection.Filldown
End If
Next i
I am using a VBA code to insert rows below based on a specific text and its occurrence .
I am using the following code to do so
Sub try()
Dim c As Range
For Each c In Range("A1:A100")
If c.Value Like "*COLLECTION*" Then
c.Offset(1, 0).EntireRow.Insert
End If
Next c
End Sub
I want to have the text BALANCE below the COLLECTION cell instead of blank row.
I want to insert the BALANCE row below the last COLLECTION entry, for example if there are two collections rows serially then I want to add the BALANCE row after the 2nd collection row. but with the above VBA code I am getting blank rows below to the each collection row.
My Collection and balance rows are in the column A
Before macro Image kindly check
After macro I want like this Image kindly check
I would do this using a loop from row 1 till last filled row in column A. Then having a boolean marker which is true while the cell value in current cell is like "*COLLECTION*" but false while not. So if the current cell is not like "*COLLECTION*" but the marker is true then the last cell above the current cell was like "*COLLECTION*". Then insert a new row with "BALANCE" if that cell is not already "BALANCE".
Sub try()
Dim c As Range
Dim lRow As Long
lRow = 1
Dim lRowLast As Long
Dim bFound As Boolean
With ActiveSheet
lRowLast = .Cells(.Rows.Count, 1).End(xlUp).Row
Do
Set c = .Range("A" & lRow)
If c.Value Like "*COLLECTION*" Then
bFound = True
ElseIf bFound Then
bFound = False
If c.Value <> "BALANCE" Then
c.EntireRow.Insert
lRowLast = lRowLast + 1
c.Offset(-1, 0).Value = "BALANCE"
c.Offset(-1, 0).Font.Color = RGB(0, 0, 0)
End If
End If
lRow = lRow + 1
Loop While lRow <= lRowLast + 1
End With
End Sub
That's typically the kind of cases you want to start from the last cell, because inserting a row will mess up all counters from what is below.
In other words, the elegant for each is not really a good idea. Too unpredictable. An ugly, old simple For Step -1 is the way to go. Something like :
Sub Macro1()
For l = 100 To 1 Step -1
If Trim(Cells(l, 1)) = "COLLECTION" And Trim(Cells(l + 1, 1)) = "DEMAND" Then
Rows(CStr(l + 1) & ":" & CStr(l + 1)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(l + 1, 1) = "BALANCE"
End If
Next l
End Sub
Just tried on EXCEL 2013, seems to work as you want. There may be more elegant solutions, though.
EDIT : the idea is the following one :
_Begin by the last line(in fact, the last line cannot work, so one optimization could be to start from the prevo=ious one), and go to the first one
_If the line testes is "COLLECTION", and the next one is "DEMAND", then you need to insert a "BALANCE" line in between. It's done in 2 times, first insert an empty line, then add "BALANCE" in the newly created line.
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