I'm using a table to pull information from separate work books.currently the table has a set end cell, but I'm pulling into too much information. I want to set the end cell to the last row of the data in column D. I need help modifying the code to set the end cell to a dynamic range.
I've already tried to use lastRow = .Cells(.Rows.Count, col).End(xlUp).Row but I keep getting
compile error
at the preceding .Offset that is invalid or unqualified reference
Sub GetData()
Dim strWhereToCopy As String, strStartCellColName As String
Dim strListSheet As String
Dim strCopySheet As String
strListSheet = "List"
On Error GoTo ErrH
Sheets(strListSheet).Select
Range("B2").Select
'this is the main loop, we will open the files one by one and copy their data into the masterdata sheet
Set currentWB = ActiveWorkbook
Do While ActiveCell.Value <> ""
strFileName = ActiveCell.Offset(0, 1) & ActiveCell.Value
strCopyRange = ActiveCell.Offset(0, 2) & ":" & lastRow =
.Cells(.Rows.Count, col).End(xlUp).Row
strWhereToCopy = ActiveCell.Offset(0, 4).Value
strCopySheet = ActiveCell.Offset(0, 6).Value
strStartCellColName = Mid(ActiveCell.Offset(0, 5), 2, 1)
Application.Workbooks.Open strFileName, UpdateLinks:=False,
ReadOnly:=True
Set dataWB = ActiveWorkbook
Sheets(strCopySheet).Select
Range(strCopyRange).Select
Selection.Copy
currentWB.Activate
Sheets(strWhereToCopy).Select
lastRow = LastRowInOneColumn(strStartCellColName)
Cells(lastRow + 1, 1).Select
Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
Application.CutCopyMode = False
dataWB.Close False
Sheets(strListSheet).Select
ActiveCell.Offset(1, 0).Select
Loop
Exit Sub
ErrH:
MsgBox "It seems some file was missing. The data copy operation is not
complete."
Exit Sub
End Sub
Related
This question already has answers here:
Handle "No cells were found" error when filtered range is empty
(4 answers)
Closed 9 months ago.
I used this yesterday and it ran fine but today I got a error "Run-time error '1004': No cells were found.
It bugs at
Range("A6:A30").SpecialCells(xlCellTypeVisible).Find("Temp").Select
Attached Macro Below
Sub HrsInput()
' Disable screen updating.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Dim workbooks and sheet names.
Dim WB1, WB2 As Workbook, Year As String
Set WB1 = ActiveWorkbook
Year = Mid(ActiveSheet.Name, 10, 4)
' Copy-n-paste raw reports.
Dim FSO As Object, SourcePath As String, DestinPath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
SourcePath = "\\ONTWSFS003\share\MIRALOMA\Brian\Raw Reports (FM)\*.xls"
DestinPath = "\\ONTWSFS003\share\MIRALOMA\Brian\"
FSO.CopyFile SourcePath, DestinPath
' Repeat below process until encountering an error.
Dim FileCount As Integer
Filename = Dir(SourcePath)
Do While Filename <> ""
FileCount = FileCount + 1
Filename = Dir()
Loop
For FileNum = 1 To FileCount
' Open raw report.
Workbooks.Open Filename:= _
"\\ONTWSFS003\share\MIRALOMA\Brian\*.xls"
' Capture raw report and total hours.
Set WB2 = ActiveWorkbook
Dim TotalOT As Double, BUNum As String, ReportDate() As String, WeekNum As Integer, ColNum As Integer
BUNum = Left(Range("A5"), 7)
ReportDate = Split(Range("A7"), " ")
WeekNum = WorksheetFunction.WeekNum(ReportDate(4))
Range("A:Q").UnMerge
' If not OT then skip the file.
If Not Range("A14:Z14").Find("OT1.5") Is Nothing Then
Range("A14:Z14").Find("OT1.5").Select
ColNum = Selection.Column
Range("A15:A300").Find("total").Select
Selection.Offset(0, ColNum - 1).Select
TotalOT = Selection.Value
' Fill out job title if empty.
Dim EmptyJobRng As Range, EmptyJobCell As Range
Set EmptyJobRng = Range("C15:C150").SpecialCells(xlCellTypeBlanks)
For Each EmptyJobCell In EmptyJobRng.Cells
If EmptyJobCell.Offset(0, 2) <> "" Then
EmptyJobCell = EmptyJobCell.Offset(-1, 0)
End If
Next EmptyJobCell
' Filter by temp only.
If Not Range("C15:C100").Find("*") Is Nothing Then
With Range("C14:Y150")
.AutoFilter field:=3, Criteria1:="<>"
.AutoFilter field:=1, Criteria1:="*Temp"
End With
End If
' Calculate total temp OT hours.
Dim TotalTempOT As Double, OT As Range
TotalTempOT = 0
Range("A14:Z14").Find("OT1.5").Select
Selection.Offset(1, 0).Select
Selection.Resize(150, 1).Select
Set OT = Selection.SpecialCells(xlCellTypeVisible)
For Each TempOT In OT.Cells
TotalTempOT = TotalTempOT + TempOT
Next TempOT
' Filter by BU and blank rows.
WB1.Activate
With Range("A5:BD30")
.AutoFilter field:=2, Criteria1:=BUNum
.AutoFilter field:=WeekNum + 2, Criteria1:="="
End With
' Locate temp row and week column to paste total temp OT hours.
Range("A6:A30").SpecialCells(xlCellTypeVisible).Find("Temp").Select
Selection.Offset(0, WeekNum + 1).Select
Selection = TotalTempOT
' Locate CEVA row and week column to paste total CEVA OT hours (total OT - total temp OT).
Range("A6:A109").SpecialCells(xlCellTypeVisible).Find("CEVA").Select
Selection.Offset(0, WeekNum + 1).Select
Selection = TotalOT - TotalTempOT
' Clear filters.
Sheets("Tracking " & Year & " (by BU)").ShowAllData
End If
' Delete current raw report.
WB2.Activate
ActiveWorkbook.Saved = True
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
WB2.Close
WB1.Activate
Next FileNum
' Update week number and weekly total OT hours.
' Week number
Range("A4").Offset(0, WeekNum).Select
Selection.Copy
Selection.Offset(0, 1).Select
Selection.PasteSpecial (xlPasteFormulas)
' Report date
Range("A5").Offset(0, WeekNum + 1).Select
Selection = "WE" & ReportDate(4)
' Weekly total OT hours
Range("A110").Offset(0, WeekNum).Select
Selection.Copy
Selection.Offset(0, 1).Select
Selection.PasteSpecial (xlPasteFormulas)
' Format Painter to new column
Range("B:B").Select
Selection.Offset(0, WeekNum - 1).Select
Selection.Copy
Selection.Offset(0, 1).Select
Selection.PasteSpecial (xlPasteFormats)
Sheets("Tracking " & Year & " (by Loc)").Select
Range("A:A").Select
Selection.Offset(0, WeekNum - 1).Select
Selection.Copy
Selection.Offset(0, 1).Select
Selection.PasteSpecial (xlPasteFormats)
' Notification when complete.
MsgBox "Data imported successfully.", vbOKOnly, "Complete"
' Enable screen updating.
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
SpecialCells(xlCellTypeVisible) raises a run-time error if there are no visible cells - one option is to ignore that error:
Dim f As range
'...
Set f = Nothing
On Error Resume Next 'ignore error if no visible cells
Set f = Range("A6:A30").SpecialCells(xlCellTypeVisible).Find("Temp")
On Error Goto 0 'stop ignoring errors
If Not f Is Nothing then
'do something with f
Else
'No visible cells, or no visible "Temp" cell...
End If
'...
I am new to this forum but have been reading a large number of posts recently as I am currently self teaching VBA for use at work!
I currently am having an issue with a bit of code that I have created. The aim of the code is to autofilter multiple sheets depending on a cell value that is double clicked on, it then copies these filtered results to another "Master Report" sheet. The issue is that it runs perfectly fine once, after which if I try to run it again or any of my other macro's within the workbook an error pops up asking me to close things to free up memory!
I have tried running the macro once, saving and closing the workbook (to clear anything that might be cached), re-opening and running and yet the same error persists. I also tried changing my .select prompts with .activate as suggested by:
How to avoid running out of memory when running VBA
but that seemed to break my code... then again I may have just implemented it wrong as I am a bit of a VBA noob Can anyone help me optimize my code to prevent this?
my code is as below:
Private Sub Merge()
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
Selection.Merge
End Sub
-------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("Master Report").Cells.Delete 'clear old master report
Column = Target.Column
Row = Target.Row
'this automatically filters information for a single part and creates a new master report with summary information
PartNumber = Cells(Row, 2).Value 'capture target part number for filtering
PartDesc = Cells(Row, 7).Value 'capture target part description
PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms
With Worksheets("NCR's") 'filter NCR sheet
.Select
On Error Resume Next
ActiveSheet.ShowAllData 'remove any previous filters
On Error GoTo 0
.Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
End With
Sheets("NCR's").Select
Sheets("NCR's").Range("A3:K3").Select
Sheets("NCR's").Range(Selection, Selection.End(xlDown)).Select 'select NCR filtered summary info
Selection.Copy
Sheets("Master Report").Select
Sheets("Master Report").Range("A1").Formula = PartNumber
Sheets("Master Report").Range("D1").Formula = PartDesc 'Print part no. & description at top of master report
Sheets("Master Report").Range("A4").Select
ActiveSheet.Paste 'paste filtered NCR info into master report
Sheets("Master Report").Range("A3:K3").Select
Call Merge
ActiveCell.FormulaR1C1 = "NCR's"
With Worksheets("CR's") 'filter CR sheet
.Select
On Error Resume Next
ActiveSheet.ShowAllData 'remove any previous filters
On Error GoTo 0
.Range("A1").AutoFilter Field:=3, Criteria1:=PartNumberWildCard
End With
Sheets("CR's").Select
Sheets("CR's").Range("A7:F7").Select
Sheets("CR's").Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Master Report").Select
Sheets("Master Report").Range("P4").Select
ActiveSheet.Paste
Sheets("Master Report").Range("RP3:U3").Select
Call Merge
ActiveCell.FormulaR1C1 = "CR's"
With Worksheets("PO's") 'filter PO sheet
.Select
On Error Resume Next
ActiveSheet.ShowAllData 'remove any previous filters
On Error GoTo 0
.Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
End With
Sheets("PO's").Select
Sheets("PO's").Range("A3:H3").Select
Sheets("PO's").Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Master Report").Select
lastRow = Sheets("Master Report").Range("A" & Rows.Count).End(xlUp).Row
lastRow = lastRow + 3
Sheets("Master Report").Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Master Report").Range("A" & lastRow - 1 & ":H" & lastRow - 1).Select
Call Merge
ActiveCell.FormulaR1C1 = "PO's"
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Another piece of info that may help is that I tried removing the last of the three filter/copy/paste routines, this allowed me to run the code about 3 times before running into the same memory error. Also the Debugger always gets stuck on the command to clear the master report at the beginning of the macro
Sheets("Master Report").Cells.Delete 'clear old master report
There are a couple of tips to speed up your macro and make it use less memory (less selecting, copying pasting). For a start it would be better to loop through your sheets rather than one long script for every one.
Dim arrShts As Variant, arrSht As Variant
arrShts = Array("NCR's", "CR's", "PO's")
For Each arrSht In arrShts
Worksheets(arrSht).Activate
'rest of your code'
Next arrSht
In the array add any other sheets you need to run the script on
Declaring variables is recommended also:
Dim masterws As Worksheet
Set masterws = Sheets("Master Report")
masterws.Activate
masterws.Range("A1").Formula = PartNumber
I haven't been able to do this 100% accurately, but you could limit your code down to something like the following
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Application.ScreenUpdating = False
Application.EnableEvents = False
Column = Target.Column
Row = Target.Row
PartNumber = Cells(Row, 2).Value 'capture target part number for filtering
PartDesc = Cells(Row, 7).Value 'capture target part description
PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms
Dim arrShts As Variant, arrSht As Variant, lastrw As Integer
Dim masterws As Worksheet
Set masterws = Sheets("Master Report")
masterws.Cells.Clear 'clear old master report
arrShts = Array("NCR's", "CR's", "PO's")
For Each arrSht In arrShts
Worksheets(arrSht).Activate
lastrw = Sheets(arrSht).Range("K" & Rows.Count).End(xlUp).Row
With Worksheets(arrSht) 'filter NCR sheet
On Error Resume Next
ActiveSheet.ShowAllData 'remove any previous filters
On Error GoTo 0
.Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
End With
Range(Cells(3, 1), Cells(lastrw, 11)).Copy
lastRow = Sheets("Master Report").Range("A" & Rows.Count).End(xlUp).Row
masterws.Activate
masterws.Range("A1").Formula = PartNumber
masterws.Range("D1").Formula = PartDesc 'Print part no. & description at top of master report
masterws.Range("A" & lastRow).PasteSpecial xlPasteValues
masterws.Range("A" & lastRow - 1 & ":H" & lastRow - 1).Select
Call Merge
ActiveCell.FormulaR1C1 = arrSht
Application.CutCopyMode = False
Next arrSht
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
This is in no way complete, and will edit as I find bits, but a good place to start to reduce the strain of your macro.
try this refactoring of your code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
Dim iRow As Long
Dim PartNumber As String, PartDesc As String, PartNumberWildCard As String
Dim masterSht As Worksheet
Set masterSht = Worksheets("Master Report")
cancel = True
iRow = Target.Row
PartNumber = Cells(iRow, 2).Value 'capture target part number for filtering
PartDesc = Cells(iRow, 7).Value 'capture target part description
PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms
'clear old master report and write headers
With masterSht
.Cells.ClearContents
.Cells.UnMerge
.Range("A1").Value = PartNumber
.Range("D1").Value = PartDesc 'Print part no. & description at top of master report
FilterAndPaste "NCR's", "K1", 2, PartNumberWildCard, .Range("A4")
FilterAndPaste "CR's", "F1", 3, PartNumberWildCard, .Range("P4")
FilterAndPaste "PO's", "H1", 2, PartNumberWildCard, .Cells(rows.count, "A").End(xlUp).Offset(3)
End With
End Sub
Sub FilterAndPaste(shtName As String, lastHeaderAddress As String, fieldToFilter As Long, criteria As String, targetCell As Range)
With Worksheets(shtName)
.AutoFilterMode = False 'remove any previous filters
With .Range(lastHeaderAddress, .Cells(.rows.count, 1).End(xlUp))
.AutoFilter Field:=fieldToFilter, Criteria1:=criteria
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then
.Resize(.rows.count - 1).Offset(1).SpecialCells(XlCellType.xlCellTypeVisible).Copy Destination:=targetCell
With targetCell.Offset(-1).Resize(, .Columns.count)
Merge .Cells
.Value = shtName
End With
End If
End With
End With
End Sub
Private Sub Merge(rng As Range)
With rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Merge
End With
End Sub
should it work for you, as it did in my tests, then I can add you some info, if you care about
I want to fill in all empty cells using values of above cells
state name
IL Mike
Sam
CA Kate
Bill
Leah
Should be as follows
state name
IL Mike
IL Sam
CA Kate
CA Bill
CA Leah
I tried the following
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection.Area
Set i = 1
For i = 1 To columnValues.Rows.Count
If (columnValues(i) = "") Then
columnValues(i) = columnValues(i - 1)
End If
Next
End Sub
I get an error when I set i. How can I modify my code
For those not requiring VBA for this, select ColumnA, Go To Special..., Blanks and:
Equals (=), Up (▲), Ctrl+Enter
should give the same result.
Given you asked for VBA, there is a quicker way than looping (the VBA equivalent of what pnuts posed above, with the additional step of removing the formula at the end):
On Error Resume Next
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
It is because i should be defined as i=1. There are although a few other problems with the code. I would change it to something like this:
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection
For i = 1 To columnValues.Rows.Count
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i - 1, 1).Value
End If
Next
End Sub
Sub fill_blanks()
Dim i As Long
i = 2 ' i<>1 because your first raw has headings "state " "name"
'Assume state is in your cell A and name is in your cell B
Do Until Range("B" & i) = ""
Range("B" & i).Select
If ActiveCell.FormulaR1C1 <> "" Then
Range("A" & i).Select
If ActiveCell.FormulaR1C1 = "" Then
Range("A" & i - 1).Copy
Range("A" & i).PasteSpecial Paste:=xlPasteValues
Else
i = i + 1
End If
Else
i = i + 1
End If
Loop
End Sub
For some cause the method used on post https://stackoverflow.com/a/20439428/2684623 not work for me. When the line .value=.value is executed, I get the error 'not available' (#N/D for local language) in the value of cells. Version of Office is 365.
I dont know the reason however with some modifications runs fine:
Sub TLD_FillinBlanks()
On Error Resume Next
With ActiveSheet.UsedRange.Columns(1)
If .Rows(1) = "" Then .Rows(1).Value = "'"
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Using loops:
Sub TLD_FillinBlanksLoop()
Dim rCell As Range
For Each rCell In ActiveSheet.UsedRange.Columns(1).Cells
If rCell.Value = "" And rCell.Row > 1 Then
rCell.FillDown
End If
Next
End Sub
I hope that can be useful for somebody. Thanks and regards.
Here is the whole module, I pasted the formulas as values at the end.
Sub FillBlanksValueAbove()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub
Copying active row of Sheet1 to Sheet2 based on cell condition (Column F="Yes") and also prevent duplication.
I tried the following
Private Sub CommandButton1_Click()
Dim CustomerName As String, Customeraddress As String, Customercity As String, Custtel As String, Custzip As String
Worksheets("sheet1").Select
CustomerName = Range("A2")
Customeraddress = Range("B2")
Customercity = Range("C2")
Custtel = Range("D2")
Custzip = Range("E2")
Worksheets("sheet2").Select
Worksheets("Sheet2").Range("B4").Select
If Worksheets("Sheet2").Range("B4").Offset(1, 0) <> "" Then
Worksheets("Sheet2").Range("B4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = CustomerName
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Customeraddress
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Customercity
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Custtel
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Custzip
Worksheets("Sheet1").Select
Worksheets("Sheet1").Range("C4").Select
End Sub
So now I need to know how to check if sheet1 Column F="Yes" for that particluar Customer. Then only copy from Sheet1 to Sheet2. If customer info is already present in Sheet2 then dont duplicate if the user clicks the button on sheet1 active row.
Try this code:
Private Sub CommandButton1_Click()
Dim lastrow As Long
'if value in column F not equal "YES" - do nothing and exit sub
If UCase(Range("F" & ActiveCell.Row).Value) <> "YES" Then Exit Sub
With ThisWorkbook.Worksheets("Sheet2")
lastrow = Application.Max(4, .Cells(.Rows.Count, "B").End(xlUp).Row + 1)
'if CustomerName is already in column B of sheet2 - do nothing and exit sub
If WorksheetFunction.CountIf(.Range("B1:B" & lastrow), _
Range("A" & ActiveCell.Row).Value) > 0 Then Exit Sub
.Range("B" & lastrow).Resize(, 5).Value = _
Range("A" & ActiveCell.Row).Resize(, 5).Value
End With
End Sub
And, please, read this post: How to avoid using Select/Active statements:)
I want to fill in all empty cells using values of above cells
state name
IL Mike
Sam
CA Kate
Bill
Leah
Should be as follows
state name
IL Mike
IL Sam
CA Kate
CA Bill
CA Leah
I tried the following
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection.Area
Set i = 1
For i = 1 To columnValues.Rows.Count
If (columnValues(i) = "") Then
columnValues(i) = columnValues(i - 1)
End If
Next
End Sub
I get an error when I set i. How can I modify my code
For those not requiring VBA for this, select ColumnA, Go To Special..., Blanks and:
Equals (=), Up (▲), Ctrl+Enter
should give the same result.
Given you asked for VBA, there is a quicker way than looping (the VBA equivalent of what pnuts posed above, with the additional step of removing the formula at the end):
On Error Resume Next
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
It is because i should be defined as i=1. There are although a few other problems with the code. I would change it to something like this:
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection
For i = 1 To columnValues.Rows.Count
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i - 1, 1).Value
End If
Next
End Sub
Sub fill_blanks()
Dim i As Long
i = 2 ' i<>1 because your first raw has headings "state " "name"
'Assume state is in your cell A and name is in your cell B
Do Until Range("B" & i) = ""
Range("B" & i).Select
If ActiveCell.FormulaR1C1 <> "" Then
Range("A" & i).Select
If ActiveCell.FormulaR1C1 = "" Then
Range("A" & i - 1).Copy
Range("A" & i).PasteSpecial Paste:=xlPasteValues
Else
i = i + 1
End If
Else
i = i + 1
End If
Loop
End Sub
For some cause the method used on post https://stackoverflow.com/a/20439428/2684623 not work for me. When the line .value=.value is executed, I get the error 'not available' (#N/D for local language) in the value of cells. Version of Office is 365.
I dont know the reason however with some modifications runs fine:
Sub TLD_FillinBlanks()
On Error Resume Next
With ActiveSheet.UsedRange.Columns(1)
If .Rows(1) = "" Then .Rows(1).Value = "'"
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Using loops:
Sub TLD_FillinBlanksLoop()
Dim rCell As Range
For Each rCell In ActiveSheet.UsedRange.Columns(1).Cells
If rCell.Value = "" And rCell.Row > 1 Then
rCell.FillDown
End If
Next
End Sub
I hope that can be useful for somebody. Thanks and regards.
Here is the whole module, I pasted the formulas as values at the end.
Sub FillBlanksValueAbove()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub