Sub iterateThroughAll()
ScreenUpdating = False
Dim wks As Worksheet
Set wks = ActiveSheet
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A1:A" & LastRow)
'Loop through each row
For Each rrow In rowRange
'Find Last column in current row
LastCol = 1 'wks.Cells(rrow, wks.Columns.Count).End(xlToLeft).Column
Set colRange = wks.Range(wks.Cells(rrow, 1), wks.Cells(rrow, LastCol)) <-------------- I get a Run-time error 1004 Application defined or object defined error.
'Loop through all cells in row up to last col
For Each cell In colRange
'Do something to each cell
Debug.Print (cell.Value)
Next cell
Next rrow
ScreenUpdating = True
End Sub
I get an Application-defined or object-defined error. The code looks okay but not sure why its not working here.
I am trying to get all the used cells in Column A
Option Explicit
Sub iterateThroughAll()
Application.ScreenUpdating = False
Dim wks As Worksheet
Set wks = ActiveSheet
Dim rowRange As Range, rrow As Range
Dim colRange As Range, Cell As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A1:A" & LastRow)
'Loop through each row
For Each rrow In rowRange
'Find Last column in current row
LastCol = 1 'wks.Cells(rrow, wks.Columns.Count).End(xlToLeft).Column
Set colRange = wks.Range(wks.Cells(rrow.Row, 1), wks.Cells(rrow.Row, LastCol))
'Loop through all cells in row up to last col
For Each Cell In colRange
'Do something to each cell
Debug.Print (Cell.Value)
Next Cell
Next rrow
Application.ScreenUpdating = True
End Sub
Related
Option Explicit
Sub ActivityMatching()
Dim wsToLook As Worksheet
Set wsToLook = ThisWorkbook.Sheets("DataOra")
Dim rngToLook As Range
Set rngToLook = wsToLook.Range("A2:H1000")
Dim wsMain As Worksheet
Set wsMain = ThisWorkbook.Sheets("Sheet2")
Dim iCell As Range
Dim rngToInsert As Range
Dim lastRow As Long
Dim whatToFind As Variant
With wsMain
.Range("A1:M1").AutoFilter Field:=1, Criteria1:="Dialer Attempt"
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngToInsert = .Range("K2:K" & lastRow).SpecialCells(xlCellTypeVisible)
For Each iCell In rngToInsert
whatToFind = iCell.Offset(, -10).Value
iCell.Value = Application.VLOOKUP(CLng(whatToFind), rngToLook, 7, False)
Next iCell
End With
End Sub
Sheet "Sheet2" column A- the key, column K where I want to put the values
Sheet "DataOra" column A the key, column G the values.
enter image description here
I received 2042 error. All the values are #N/A
enter image description here
I'm trying to find the last empty row on column "D" and then perform a Vlookup function from matching value from column "A" with another sheet, and autofill this formula down.
The problem is that i'm getting an error in the vlookup.
Dim myRange As Range
Set myRange = Worksheets("IDL MASTER").Range("C:AV")
Dim Rng As Range
Set Rng = Worksheets("Planilha2").Range("A:A")
LastBlankRow = Cells(Rows.Count, 4).End(xlUp).Row + 1
Cells(LastBlankRow, 4).Select
ActiveCell.Value = Application.WorksheetFunction.VLookup(Rng, myRange, 46, False)
ActiveCell.AutoFill Destination:=Range(ActiveCell, Cells(Cells(Rows.Count, "A").End(xlUp).Row, "D"))
End sub
Sub FillColumnD()
Dim ws1 As Worksheet: Set ws1 = Worksheets("IDL MASTER")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Planilha2")
Dim lRow_ColA As Integer: lRow_ColA = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Dim lRow_ColD As Integer: lRow_ColD = ws2.Cells(Rows.Count, 4).End(xlUp).Row + 1
Dim LookupRange As Range: Set LookupRange = ws1.Range("C:AV")
Dim FillRange As Range: Set FillRange = ws2.Range(Cells(lRow_ColD, 4), Cells(lRow_ColA, 4))
Dim rCell As Range
For Each rCell In FillRange
rCell.FormulaR1C1 = Application.WorksheetFunction.VLookup(rCell.Offset(0, -3), LookupRange, 46, False)
Next rCell
End Sub
I have an old workbook with Conditional Formatting that has got out of hand in terms of random conditional formatting having evolved. I would like to loop through the sheet and delete all the conditional formatting that only refers to one cell (but preserve other formatting in the same cell and of course preserve the cell value etc.)
I have written the code in a separate sheet so that (1) I can re-use it and (2) the workbook itself doesn't need macros
So far, I can identify the cells but can't delete the formatting. The code I have is:
Option Explicit
Sub Delete_Conditional()
Dim fc As FormatCondition
Dim lLastRow As Long, lLastCol As Long
Dim rAllCells As Range, rCell As Range
Dim ws As Worksheet
Dim wb As Workbook
Set wb = Workbooks("Book1.xlsx")
Set ws = wb.Worksheets("Sheet1")
'Find last cell and set a range to cover all cells
lLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
lLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rAllCells = Range(Cells(1, 1), Cells(lLastRow, lLastCol))
'Loop through all cells
For Each rCell In rAllCells.Cells
'Loop through all FormatConditions in the cell
For Each fc In rCell.FormatConditions
'Determine if the FormatCondition only applies to one cell
If fc.AppliesTo.Cells.Count = 1 Then
Debug.Print fc.AppliesTo.Address
'I have tried fc.Delete
'I have tried fc.AppliesTo.Delete
End If
Next fc
Next rCell
End Sub
When I go back to the sheet, I can see the formatting still exists.
When deleting from a collection of items sometimes it works better if you work backwards:
Sub Delete_Conditional()
Dim fc As FormatCondition
Dim lLastRow As Long, lLastCol As Long
Dim rAllCells As Range, rCell As Range
Dim ws As Worksheet
Dim wb As Workbook, i As Long
Set wb = Workbooks("Book1.xlsx")
Set ws = wb.Worksheets("Sheet1")
'Find last cell and set a range to cover all cells
lLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
lLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rAllCells = Range(Cells(1, 1), Cells(lLastRow, lLastCol))
'Loop through all cells
For Each rCell In rAllCells.Cells
'Loop through all FormatConditions in the cell
For i = rCell.FormatConditions.Count To 1 Step -1
With rCell.FormatConditions(i)
If .AppliesTo.Cells.Count = 1 Then
Debug.Print .AppliesTo.Address
.Delete
End If
End With
Next i
Next rCell
End Sub
I am trying to build a vba script to copy the values in the first column of sheet2 100 times to a first column on sheet1
I have some code, but it throws Run-time error 1004 to me, so can't figure out where the mistake is.
For now I have made the code to copy the values on the sheet2 to first empty row in first column in sheet1, but it doesn't work.
For example, I have on the Sheet2
Ara
Cl
RT
And the function will return to me on the list 1
Ara
.
.
.
Ara (X times for each element)
Public Sub Data()
Dim rngSinglecell As Range
Dim rngcells As Range
Dim i As Long
Dim lastrow As Long
Set rngcells = Sheets("Sheet2").Range("A1", Range("A1").End(xlUp))
lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For Each rngSinglecell In rngcells
For i = 1 To 100
Sheets("Sheet1").Range(Cells(i + lastrow, 1)) = rngSinglecell.Value
Next
Next
End Sub
Run-time error 1004
thank you very much for help!
Problem:
While pasting you are Passing Cells without any reference to sheets that could cause this error.
Use of xlUp should be xlDown
Lastrow should be Recalculated in Iteration or 100 Should be added to it.
Try:
Public Sub Data()
Dim rngSinglecell As Range
Dim rngcells As Range
Dim i As Long
Dim lastrow As Long
Dim cel As Range
With Worksheets("Sheet2")
Set rngcells = .Range("A1", .Range("A1").End(xlDown))
End With
With Worksheets("Sheet1")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).row
For Each cel In rngcells
.Range(.Cells(lastrow + 1, 1), .Cells(lastrow + 100, 1)) = cel.Value
lastrow = lastrow + 100
Next
End With
End Sub
Demo:
Sub FillEmptyCell()
Dim rng As Range
Dim i As Long
Dim cell As Range
Dim sht As Worksheet
Set sht = ActiveWorkbook.Sheets("Sheet1")
sht.Activate
Set rng = Range(Range("C12"), Range("AD" & sht.UsedRange.Rows.Count))
For Each cell In rng
If cell.Value = "" Then
cell.Value = "0"
End If
Next
End Sub
I am trying to fill my blank spaces in sheet with zero dynamically.However,
I don't want this to fill zeroes in row that have no data. can someone help please?
See how this works,
Sub ZeroStuff()
Dim LstRw As Long, rng As Range, sh As Worksheet, c As Range
Set sh = Sheets("Sheet1")
With sh
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
Set rng = .Range("C12:C" & LstRw).SpecialCells(xlCellTypeBlanks)
For Each c In rng.Cells
.Range(c.Offset(, 1), c.Offset(, 27)) = 0
Next c
End With
End Sub