Currently, I have the following set of codes which is to help me run Macro1 for every cell in Column D, so long each cell is not blank/empty. However, with the codes below, it is not calling Macro1 at the last not empty/blank cell of the column. Any idea why is it so?
An update: I found that the loop ended early at Next R. It didn't proceed on. Any idea why so?
Sub testing()
Dim Rl As Long ' last row
Dim Tmp As Variant
Dim CellValue As Range
Dim R As Long ' row counter
With ThisWorkbook.ActiveSheet
'To find out how many rows in D, counting from the last cell (Not blank)
Rl = .Cells(.Rows.Count, "D").End(xlUp).Row
' work on column D
For R = 1 To Rl ' start the loop in row 1
Tmp = .Cells(R, "D").Value
If Len(Tmp) Then
Cells(R, "D").Select
Call Macro1
End If
Rl = .Cells(.Rows.Count, "D").End(xlUp).Row
Next R
End With
End Sub
Macro1:
Dim str As String
Dim ArrStr() As String
Dim i As Long
Dim y As Long
Dim RowsAdded As Boolean
RowsAdded = False
'Fill variables: str is the value of the active cell, ArrStr splits this value at the comma
str = ActiveCell.Value
ArrStr = Split(str, ", ")
'Loop through each ArrStr to populate each cell below the activecell
For i = 0 To UBound(ArrStr)
ActiveCell.Offset(i, 0).Value = ArrStr(i)
If RowsAdded = False Then
For y = 1 To UBound(ArrStr)
ActiveCell.Offset(1, 0).EntireRow.Insert xlDown
Next y
RowsAdded = True
End If
Next i
End Sub
Try the following code. You had most of it in your original post above but I think were a bit fixated on the for loop and the number of cells in column D whilst missing that you already had set the exit criteria..
Sub testing()
Dim myRow As Long: myRow = 1
With ThisWorkbook.ActiveSheet
'Exit when first non empty cell is encountered
Do While Len(.Cells(myRow, "D").Value)
Cells(myRow, "D").Select
Call macro
myRow = myRow + 1
Loop
End With
End Sub
Just putting out there in case anybody like to see how I did it. But its built upon #freeflow's answer:
Sub testing()
Dim myRow As Long: myRow = 1
With ThisWorkbook.ActiveSheet
'Exit when first non empty cell is encountered
Do While Len(.Cells(myRow, "D").Value) Or Len(.Cells(myRow, "D").Value) = 0
lastRow = Range("D65000").End(xlUp).Row
Cells(myRow, "D").Select
Call Macro1
myRow = myRow + 1
If myRow = finalRow Then
Cells(finalRow, "D").Select
Call Macro1
Exit Do
End If
Loop
End With
End Sub
Related
I have this code where i can search for the first two blank cells and place an "x" on the first cell that contains the blank. For testing purposes i have separated the the code into two command buttons. For First command button searches the blank cells and places the "x" and second command button finds the "x" and deletes the row and all other rows after it.
My problem is, i want it to delete all rows after the "x" but to leave the last row which contains the overall Total.
Here is my code from the two command buttons :
Sub findEmptyCells()
Dim lastRow As Long, i As Long
Dim firstEmptyCell As Range
lastRow = Cells(Rows.Count, 12).End(xlUp).Row
For i = 12 To lastRow
If Cells(i, 12).Value = "" And Cells(i + 1, 12).Value = "" Then
Set firstEmptyCell = Cells(i, 12)
Exit For
End If
Next i
MsgBox ("There are no two empty cells in a row")
Exit Sub
End If
firstEmptyCell.Value = "x"
End Sub
Sub Deleterows_Click()
Dim srchRng As Range
Set srchRng = Range("L7:L500")
Dim c As Range
For Each c In srchRng
If c.Value = "x" Then
Range(c, Range("L500")).EntireRow.Delete
Exit For
End If
Next
End Sub
Delete Rows Identified By Merged Cells
Option Explicit
Sub DeleteRows()
Const Col As String = "L"
Const fRow As Long = 13
Const mcCount As Long = 5
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim cCell As Range
Dim r As Long
For r = fRow To lRow - mcCount
'Debug.Print r
Set cCell = ws.Cells(r, Col)
If cCell.MergeArea.Cells.Count = mcCount Then
If Len(CStr(cCell.Value)) = 0 Then
cCell.Offset(-1).Resize(lRow - r + 1).EntireRow.Delete
Exit For
End If
r = r + mcCount - 1
End If
Next r
MsgBox "Rows deleted.", vbInformation
End Sub
I'm trying to concatenate the values for cells in a given row (say C3:F3) and in that same row (on the same worksheet) go to first empty cell to the left of the cells that were concatenated (say B3) and input the concatenated values. The code below works the first time but I keep on getting a run-time error 1004 when the following line of code is run ws.Range("B3").End(xlDown).Offset(1, 0).Value = varConctnt, that is, the next set of cells in the next row are selected (say C4:F4) and I want to input the concatenated value in cell B4. I've done my best to declare objects to get around the issue but the error keeps on appearing.
Thanks in advance.
Sub ConcatenateReal2()
Dim rng As Range, iRow As Integer, iCol As Integer, i As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Range("C3").Select
Set rng = ActiveSheet.Range(ActiveCell.End(xlToRight), ActiveCell.End(xlDown))
Dim varConctnt As Variant
For iRow = 1 To rng.Rows.Count
For iCol = 1 To rng.Columns.Count
If Not rng(iRow, iCol).Value = vbNullString Then
varConctnt = varConctnt & "," & rng(iRow, iCol).Value
End If
Next iCol
Range("B3").Activate
If IsEmpty(ActiveCell) Then
ActiveCell.Value = varConctnt
Else
ws.Range("B3").End(xlDown).Offset(1, 0).Value = varConctnt
End If
varConctnt = ""
skip1:
Next iRow
End Sub
(Untested)
Sub ConcatenateReal2()
Dim rng As Range, c As Range
Dim sep, rw as Range, v, s
With ActiveSheet.Range("C3")
Set rng = .Parent.Range(.End(xlToRight), .End(xlDown))
End With
For Each rw in rng.Rows 'loop over rows
sep = "" 'reset separator
s = ""
For Each c in rw.Cells
v = c.value
If Len(v) > 0 Then
s = s & sep & v
sep = ","
end if
next c
rw.cells(1).offset(0, -1).value = s
Next rw
End Sub
Haven't ever had to do this for an entire range, but only per cell for one column, so I need to figure out if this is even right. I want to loop through a column range (E2:S2) and if every cell is blank, then delete the whole row. If there is at least one cell in that range with data, then keep the row.
How could I edit this in order to create that For/Next loop?
Sub DeleteRowsWithEmptyColumnDCell()
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.ActiveSheet.Range("E2:S2") ' <- and then loop to next row, etc..
With rng
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
.Item(i).EntireRow.Delete
End If
Next i
End With
End Sub
Would I need to add the for/next loop around the rng?
Have in mind Lastrow replace .Rows.Count. If needed, change the column for which Lastrow is calculated. For this example i use Column A.
Try:
Option Explicit
Sub DeleteRowsWithEmptyColumnDCell()
Dim rng As Range, cell As Range
Dim i As Long, y As Long, DeleteRow As Long, Lastrow As Long
Dim cellEmpty As Boolean
With ThisWorkbook.ActiveSheet
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For y = Lastrow To 2 Step -1
Set rng = .Range("E" & y & ":S" & y)
cellEmpty = False
For Each cell In rng
If cell.Value <> "" Then
cellEmpty = False
Exit For
Else:
cellEmpty = True
DeleteRow = cell.Row
End If
Next
If cellEmpty = True Then
.Rows(DeleteRow).EntireRow.Delete
End If
Next y
End With
End Sub
I am looking to fill a spreadsheet with data repeating data, so 25 appointments for today, 25 appointments for tomorrow with the same name and so on for as far as possible.
Is the a simple way of filling the table where the date increases in blocks of 25?
Example of what i am trying to do
Try using this you might be able to achieve what you want ,any problems shout out
'to change the date to the next day
Public Function ExtraDay(strDate As String)
Dim tDay As Date
tDay = Format(DateAdd("d", 1, strDate), "dd/mm/yy")
ExtraDay = tDay
End Function
'gets the last used row
Function getThelastUsedRowAddress() As Integer
'Get Last Row in Worksheet UsedRange
Dim LastRow As Range, ws As Worksheet
Set ws = ActiveSheet
MsgBox ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
getThelastUsedRowAddress = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
End Function
'button command on the sheet
Private Sub CommandButton1_Click()
Dim n, t As Integer
Dim ns As String
n = getThelastUsedRowAddress()
t = n + n
ns = CStr(t)
Call getThelastUsedRow(CStr(n))
Call TheLoopRange(CStr(n) + 1, ns)
End Sub
'get the last used and paste after
Sub getThelastUsedRow(address As String)
'Get Last Row in Worksheet UsedRange
Dim LastRow As Range, ws As Worksheet
Dim numcopied As Integer
Dim numonpaper As Integer
Set ws = ActiveSheet
numcopied = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
numonpaper = numcopied + 1
ws.UsedRange.Copy 'Destination:=Wst.Cells(1, 1)
'paste
Sheets("Sheet1").Range("A" & numonpaper).PasteSpecial xlPasteValues
End Sub
'loop the pasted range and change date to the next day from date
Sub TheLoopRange(rangestart As String, rangeend As String)
'rangestart,rangeend
Dim rCell As Range
Dim rRng As Range
Set rRng = Sheet1.Range("E" & rangestart & ":E" & rangeend)
For Each rCell In rRng.Cells
'MsgBox rCell.Value
rCell.Value = ExtraDay(rCell.Value)
Next rCell
End Sub
Lets as assume that:
We use Sheet1
Company column is column D
Date column is column I
Pease try:
Option Explicit
Sub Test()
Dim Lastrow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row
For i = 2 To Lastrow
If i = 2 Then
.Cells(i, 9).Value = Date + 1
ElseIf i <> 2 And .Cells(i, 4).Value = 1 Then
.Cells(i, 9).Value = .Cells(i, 9).Offset(-1, 0).Value + 1
Else: .Cells(i, 9).Value = .Cells(i, 9).Offset(-1, 0).Value
End If
Next i
End With
End Sub
I need to insert rows according to the condition that the cell in DQ column is non-blank then I have to insert a new row, and also paste the row data in the new row data.
The problem is that I am not able to insert a row above the matched column and also I don't know how to copy the text.
Following is the code that I have:
Sub Macro()
nr = Cells(Rows.Count, 5).End(xlDown).Row
For r = 4 To nr Step 1
If Not IsEmpty(Cells(r, 121).Value) Then
Rows(r + 1).Insert Shift:=xlDown
Rows(r + 1).Interior.ColorIndex = 16
End If
Next
End Sub
For this you will have to use a reverse loop. I quickly wrote this code and it is not tested. Let me know if you get any error.
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, r As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Get the last row which has data in Col DQ
lRow = .Cells(.Rows.Count, 121).End(xlDown).Row
'~~> Reverse Loop
For r = lRow To 4 Step -1
If Not IsEmpty(.Cells(r, 121).Value) Then
.Rows(r + 1).Insert Shift:=xlDown
.Rows(r + 1).Interior.ColorIndex = 16
End If
Next
End With
End Sub
I actually found the answer in this forum itself. Pasting the code and the link. Thanks a lot people.
Insert copied row based on cell value
Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "DQ"
StartRow = 3
BlankRows = 1
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) <> "" Then
.Cells(R, Col).EntireRow.Copy
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
.Cells(R, Col).EntireRow.Interior.ColorIndex = 4
End If
Next R
End With
Application.ScreenUpdating = True
End Sub