In Column A, I have the below values from 1 to 20.
1. NBC997
2. EVO463
3. EVO426
4. EVO420
5. EVO826
6. EVO820
7. EVO863
8. CRO001
9. BCA915
10. SBH121
11. KEN500
12. GAM201
13. GAM1011
14. GAM101
15. SPR577
16. SPR580
17. SPR579
18. SPR576
19. DON201
20. MOR101
My formula below should be looking at column A and deleting the entire row if the left 2 characters <> "EV".
Once it finds one iteration it stops and doesn't go to the next line.
Sub remove()
Dim i As Long
For i = 1 To 20
If Left(Cells(i, "A"), 2) <> "EV" Then
Cells(i, "A").EntireRow.Delete
Else
End If
Next i
End Sub
I would not use the delete entire row. I would move the data up one row and then clear the contents of the last row.
Sub remove()
Dim i As Long
Dim x As Long
Dim lastCol As Long
Dim lastRow As Long
Const dataColumn As Long = 1
Const SearchPhrase As String = "EV"
Const firstRow As Long = 1
lastCol = Cells(firstRow, Columns.Count).End(xlToLeft).Column
lastRow = Cells(Rows.Count, dataColumn).End(xlUp).Row
x = 0
For i = lastRow To firstRow Step -1
If Left(Cells(i, dataColumn), Len(SearchPhrase)) <> SearchPhrase Then
If i = lastRow Then
Range(Cells(lastRow, dataColumn), Cells(lastRow, lastCol)).ClearContents
Else
Range(Cells(i, dataColumn), Cells(lastRow - 1 - x, lastCol)).Value = _
Range(Cells(i + 1, dataColumn), Cells(lastRow - x, lastCol)).Value
Range(Cells(lastRow - x, dataColumn), Cells(lastRow - x, lastCol)).ClearContents
End If
x = x + 1
End If
Next i
End Sub
Related
I have an excel sheet full of data sections, each data section is separated by an empty row.
While I'm looping over each row of the worksheet, I need to find the index of the next blank row so I can know where the current data section ends & apply modifications to it before passing to the next data section.
Here is an example of my first loop (inside this loop I need to find the index of the next blank row):
Dim x As Integer
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1").Select
For x = 1 To lastrow
If Left(Cells(x, "A").Value, 8) = "!JOURNAL" And Not (IsEmpty(Cells(x, "H"))) Then
'''Here I need to add another loop to find the index of my next blank row please'''
idxblankrow = Range(Cells(x, "A")).CurrentRegion.Row
MsgBox "Idx blank row is " & idxblkrow
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "H")).Cut Range(Cells(x + 2, "B"), Cells(idxblankrow - 1, "I"))
Range(Cells(x, "H")).Select
Selection.Copy
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "A")).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next
Here is another failed attempt(the second nest For loop is what tries to search for the blank row):
Dim x As Integer
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For x = 1 To lastrow
If Left(Cells(x, "A").Value, 8) = "!JOURNAL" And Not (IsEmpty(Cells(x, "H"))) Then
For j = x To lastrow
If IsEmpty(Cells(j, "A")) Then idxblankrow = Cells(j, "A").Row
MsgBox "blank row " & idxblankrow
Exit For
End If
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "H")).Cut Range(Cells(x + 2, "B"), Cells(idxblankrow - 1, "I"))
Range(Cells(x, "H")).Select
Selection.Copy
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "A")).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next
Any kind of help would be hella appreciated, thanks !
Please, use the next adapted way. It does not select, it does not use clipboard:
For x = 1 To LastRow
If left(cells(x, "A").Value, 8) = "!JOURNAL" And Not (IsEmpty(cells(x, "H"))) Then
idxblankrow = cells(x, "A").End(xlDown).Row
MsgBox "Idx blank row is " & idxblankrow
Range(cells(x + 2, "A"), cells(idxblankrow - 1, "H")).Cut cells(x + 2, "B")
'copy the value from "H" on the whole A:A column portion:
Range("A" & x & ":A" & idxblankrow - 1).Value = cells(x, "H").Value 'not using clipboard...
Stop 'check when stopped here if it did what you need
'if so, please press F5 to continue and check again.
'you probably need to increment x to continue iteration after the processed portion
'something as:
x = x + (idxblankrow - x) + 2 '???
End If
Next x
You probably need now to increment x with the number of rows which have been processed, but you must explain in words what you try accomplishing. Guessing is not an appropriate way of working here...
If I want to know if an entire row is empty, I just concatenate the whole row and check the length. If this is zero, then the row is blank. Else, it's not.
See following exemplary screenshot (only the fourth row is empty, which is seen in the fourth formula, giving zero as a result):
Use flags to identify the start and end of the group. This deals with multiple blank rows between groups.
Sub macro()
Dim ws As Worksheet
Dim lastrow As Long, i As Long, n As Long
Dim x As Long, z As Long
Dim bStart As Boolean, bEnd As Boolean
Set ws = ThisWorkbook.Sheets("Sheet1")
n = 0
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
' start of group
If Len(.Cells(i, "A")) > 0 Then
bStart = True
n = n + 1
End If
' end of group look ahead
If Len(.Cells(i + 1, "A")) = 0 Then
bEnd = bStart
End If
' valid range
If bStart And bEnd Then
x = i - n + 1 ' first row of group
MsgBox "Processing rows " & x & " to " & i
If Left(.Cells(x, "A").Value, 8) = "!JOURNAL" _
And Not (IsEmpty(Cells(x, "H"))) Then
' process rows x to i
End If
' reset flags
n = 0
bStart = False
bEnd = False
End If
Next
End With
End Sub
All these answers could be much simpler. Consider this:
iNextBlankRow = Sheet1.Range("A" & iNextBlankRow & ":A50").SpecialCells(xlCellTypeBlanks).Cells(1, 1).Row
To demonstrate, run this macro:
Sub BlankRowTest()
Dim iNextBlankRow As Long
Dim r As Long
iNextBlankRow = 1
For r = 1 To 50
If iNextBlankRow <= r Then iNextBlankRow = Sheet1.Range("A" & iNextBlankRow + 1 & ":A50").SpecialCells(xlCellTypeBlanks).Cells(1, 1).Row
Debug.Print r, iNextBlankRow, "'" & Sheet1.Cells(r, 1).Value & "'"
Next
End Sub
This code loops through the first 50 rows looking for the next blank row. When it finds it, it assigns it to the variable iNextBlankRow. We don't bother updating that until our current row (r) is greater than or equal to INextBlankRow. At that point we look again starting from the next row.
The issue is that up to a certain point, each column is copied to the right, and then it suddenly starts going to the left, and ignoring a column.
I didn't write the thing, have as yet been unable to pick it apart to even attempt to solve it properly. I've fiddled with it, but haven't gotten any useful results to go off of.
For colx = 2 To maxColumns Step 2
ActiveSheet.Columns(colx).Insert
ActiveSheet.Columns(colx - 1).Interior.Color = RGB(255, 153, 0)
Next
maxRows = ActiveSheet.UsedRange.Rows.Count
maxColumns = ActiveSheet.UsedRange.Columns.Count * 2 + 1
For colx = 2 To maxColumns Step 2
For iRow = 1 To maxRows
WorksheetFunction.CountA (Columns(1))
'If there is a comment, paste the comment text into column D and delete the original comment.
ActiveSheet.Cells(iRow, colx).Value = Trim(ActiveSheet.Cells(iRow, colx - 1).Value)
Next iRow
Next
As you can see in the image below, Rental Amount and Deposit Amount have worked, though Deposit Amount has also happend in the column AL, which should have Rent Frequency. Similarly Column AT should have "PROPERTY TYPE" and AV should have "FURNISHED TYPE" and so on and so forth...
Replace your entire code with this:
Option Explicit
Sub Macro1()
Dim LCol As Long, LRow As Long, i as Long, j as Long
With ThisWorkbook.Worksheets("Sheet1")
LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A1", .Cells(LRow, LCol)).Interior.Color = RGB(255, 153, 0)
For i = 1 To (LCol*2 - 1) Step 2
.Columns(i+1).Insert
For j = 1 To LastRow
.Cells(j, i+1).Value = Trim(.Cells(j, i).Value)
Next j
Next i
End With
End Sub
I was provided with some code that a guy who is not longer available did. say you have a table with five columns. the first four columns get filled with a query that works fine, then there is this piece of code that completes the fifth column. When I run it it gets me "Subscript out of range (Error 9)" when it goes for the fifth row and below. The 1,2,3 and 4 work ok. Any help would be great! The error is highlighted on the line above the fisrt "for"
Function HorasSemana() As Double
Dim sumaHoras As Double
Dim lRow As Integer
Dim semanas(1 To 4) As Integer
lRow = DatosOmnia.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lRow
semanas(i - 1) = WorksheetFunction.WeekNum(DatosOmnia.Cells(i, "C"), vbMonday)
'MsgBox WorksheetFunction.WeekNum(DatosOmnia.Cells(i, "C"), vbMonday)
Next i
'lRow toma el valor con respecto a la hoja "Horas Semanales"
lRow = Worksheets("Horas Semanales").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To sizeOf(semanas) '(UBound(semanas, 1) - LBound(semanas, 1) + 1)
sumaHoras = 0
For j = 2 To lRow
If WorksheetFunction.WeekNum(Worksheets("Horas Semanales").Cells(j, "B"), vbMonday) = semanas(i) Then
sumaHoras = sumaHoras + Worksheets("Horas Semanales").Cells(j, "C").Value
DatosOmnia.Cells(i + 1, "F") = sumaHoras
End If
Next j
Next i
HorasSemana = sumaHoras
End Function
You can resize your array according to lRow:
Dim lRow As Long
Dim semanas() As Long
lRow = DatosOmnia.Cells(Rows.Count, 1).End(xlUp).Row
ReDim semanas(1 to lRow-1)
Typically Long is preferable to Integer - it doesn't "cost" more, and it's safer if your data grows larger
I have a spreadsheet that contains data starting in row 2 column 1 and has 42 columns. I am trying to write a VBA code that will search all rows of my data starting with row 2 and if the value in column 32 is greater than 575, I need the code to insert enough rows below that row so that whatever the value was (whether it be 600 or 2,000) can be split into increments of 575. So for example, if row 5 column 32's value is 800, i want the code to add a row below row 5, and i want it to autofill the new row with the value of 575 in column 32 and replace the value in the original row with whatever it was minus 575. Also, in the first column of my data I have dates. For each new row that is created, I want it to be a week earlier than the date in the original row. Here is an example of what my data looks like:
Column1 ...Column 32.......Column 42
8/15/2019 // 3873
Here is what i want it to look like after I run the code.
Column1 ...Column 32......Column 42
8/15/2019 // 423
8/8/2019 // 575
8/1/2019 // 575
7/25/2019 // 575
7/18/2019 // 575
7/11/2019 // 575
7/4/2019 // 575
The slash marks are just there to show the separation in columns. And I want the data from all the other columns to stay the same as the row above. Is there a good way to do this?
This is the code I've come up with so far. However, the problem with it is I can't seem to figure out how to program it so that it know how many rows to add based on how large the quantity is. As of now, it just adds a row below any row that the value of column 32 is greater than 575. Also, it just adds blank rows. I don't have anything in my code that says what values to put in the newly created rows
Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim LargeOrder As Integer
Col = "AF"
StartRow = 1
BlankRows = 1
LargeOrder = 575
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col).Value > LargeOrder Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
As I mentioned before, I need the code to add however many rows needed to accommodate the original quantity to be broken into increments of 575, and also subtract a week with every row created. Thank you in advance for your help.
There are numerous way to achieve the objective. One is instead of reverse loop, you go down inserting balance amount and again on next row recalculated and so on till blank is encounters. May try the code tested with makeshift data
Option Explicit
Sub addLine()
Dim Col As Variant
'Dim BlankRows As Long
'Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim LargeOrder As Integer
Dim Ws As Worksheet
Dim ActNum As Double, Balance As Double
Set Ws = ThisWorkbook.ActiveSheet
Col = "AF"
StartRow = 2
'BlankRows = 1
LargeOrder = 575
R = StartRow
With Ws
ActNum = .Cells(R, Col).Value
Do While ActNum <> 0
If ActNum > LargeOrder Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Range(.Cells(R, 1), .Cells(R, 42)).Copy Destination:=.Cells(R + 1, 1)
.Cells(R + 1, 1).Value = .Cells(R + 1, 1).Value - 7
'simpler calculation
Balance = IIf(ActNum Mod LargeOrder > 0, Int(ActNum / LargeOrder) * LargeOrder, ActNum - LargeOrder)
'Balance = IIf(ActNum Mod LargeOrder > 0, Int(ActNum / LargeOrder) * LargeOrder, Int(ActNum / LargeOrder) * LargeOrder - LargeOrder)
.Cells(R + 1, Col).Value = Balance
.Cells(R, Col).Value = ActNum - Balance
End If
R = R + 1
ActNum = .Cells(R, Col).Value
Loop
End With
End Sub
Edit: may try the modified code below for the variance in requirement
Option Explicit
Sub addLine2()
Dim Col As Variant
Dim LastRow As Long
Dim R As Long, i As Long
Dim StartRow As Long
Dim RowtoAdd As Long
Dim Ws As Worksheet
Dim ActNum As Double, Balance As Double
Set Ws = ThisWorkbook.ActiveSheet
Col = "AS"
StartRow = 2
LastRow = Ws.Cells(Rows.Count, Col).End(xlUp).Row
R = StartRow
With Ws
Do
RowtoAdd = .Cells(R, Col).Value
LastRow = LastRow + RowtoAdd
For i = 1 To RowtoAdd
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R, 1).EntireRow.Copy Destination:=.Cells(R + 1, 1)
.Cells(R + 1, 1).Value = .Cells(R + 1, 1).Value - 7
.Cells(R + 1, 32).Value = ""
R = R + 1
Next i
R = R + 1
Loop Until R > LastRow
End With
End Sub
I've got a function which merges cells in table if whole range has the same value (eg. if A1:G1 is equal to A2:B2 it will merge cells like A1&A2, B1&B2 etc. More here: How to check if two ranges value is equal)
Now I would like, to change color on table created by that funcion, like first row (doesn't matter if merged or no) filled with color, second blank etc. but I have no idea whether I should color it with merging function or create another which will detect new table with merged rows as one etc. Below is my code:
Sub test()
Dim i As Long, j As Long, k As Long, row As Long
row = Cells(Rows.Count, 2).End(xlUp).row
k = 1
For i = 1 To row Step 1
If Cells(i, 1).Value = "" Then Exit For
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
k = i + 1
End If
Next i
End Sub
Try:
Option Explicit
Sub test1()
Dim LastColumn As Long, LastRow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To LastRow Step 2
.Range(Cells(i, 1), .Cells(i, LastColumn)).Interior.Color = vbGreen '<- You could change the color
Next i
End With
End Sub
Before:
After:
Edited Solution:
Option Explicit
Sub test1()
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .UsedRange
.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Table1"
.ListObjects("Table1").TableStyle = "TableStyleLight3"
End With
End Sub
Result:
So, after some time I've figured it out by myself. Below is the code:
Dim i As Long, j As Long, k As Long, l As Long, c As Integer
row = Cells(Rows.Count, 2).End(xlUp).row
k = 7
c = 1
For i = 7 To row Step 1
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
Select Case c
Case 0
Range(Cells(k, 1), Cells(k, 3)).Interior.Color = xlNone
c = 1
Case 1
For l = 0 To i - k Step 1
Range(Cells(k + l, 1), Cells(k + l, 3)).Interior.Color = RGB(217, 225, 242)
Next l
c = 0
End Select
k = i + 1
End If
Next i