I want to loop this macro through all sheets. The macro current works on just one sheet but when I try to add a For Next loop it says the variable is not defined. Basically, I want it to find the text "Total Capital" and delete everything below it for all but two sheets in the workbook. Thank you in advance. This is what I have currently.
Sub DeleteBelowCap()
Dim ws As Worksheet
For Each ws In Worksheets
Dim lngFirstRow As Long, lngLastRow As Long
Dim lngCount As Long
Dim fRg As Range
Set fRg = Cells.Find(what:="Total Capital", lookat:=xlWhole)
lngFirstRow = fRg.Row + 1
lngLastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
For lngCount = lngLastRow To lngFirstRow Step -1
Rows(lngCount).EntireRow.Delete
Next lngCount
Set fRg = Nothing
Next
End Sub
You must be careful since you are looping worksheets NOT to use references like ActiveSheet in your code, or unqualified range references. We see this in two places in your code:
lngLastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
and
Set fRg = Cells.Find(what:="Total Capital", lookat:=xlWhole)
Both of these spell trouble - you will be working on the activesheet in both cases, I think. Or in the latter case, possibly on the worksheet module the code is in (if it is in a worksheet module and not a standard code module).
So, fixes in place:
Sub DeleteBelowCap()
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCount As Long
Dim fRg As Range
Dim ws As Worksheet
For Each ws In Worksheets
Set fRg = ws.Cells.Find(What:="Total Capital", LookAt:=xlWhole)
If Not fRg Is Nothing Then
lngFirstRow = fRg.Row + 1
lngLastRow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
ws.Range(ws.Cells(lngFirstRow, 1), ws.Cells(lngLastRow, 1)).EntireRow.Delete
End If
Set fRg = Nothing
Next
End Sub
I'm not a fan of deleting rows, especially row by row. So if your goal is just to clear everything below the found cell, then using a clear method is simple without any extra logic (all the way to the bottom):
Sub DeleteBelowCap2()
Dim fRg As Range
Dim ws As Worksheet
For Each ws In Worksheets
Set fRg = ws.Cells.Find(What:="Total Capital", LookAt:=xlWhole)
If Not fRg Is Nothing Then
ws.Range(ws.Cells(fRg.Row + 1, 1), ws.Cells(Rows.Count, 1)).EntireRow.Clear
End If
Set fRg = Nothing
Next
End Sub
Clear Below the First Found Cell
Option Explicit
Sub ClearBelowCap()
Const SearchString As String = "Total Capital"
Const ExceptionsList As String = "Sheet1,Sheet2"
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, ",")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
ClearBelowFirstFoundCell ws, SearchString
End If
Next ws
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a worksheet ('ws'), clears the cells in the rows
' that are below the row of the top-most cell
' whose contents are equal to a string ('SearchString').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ClearBelowFirstFoundCell( _
ByVal ws As Worksheet, _
ByVal SearchString As String)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
With ws.UsedRange
Dim lCell As Range: Set lCell = .Cells(.Rows.Count, .Columns.Count)
Dim fCell As Range
Set fCell = .Find(SearchString, lCell, xlFormulas, xlWhole)
If fCell Is Nothing Then Exit Sub
Dim fRow As Long: fRow = fCell.Row
Dim lRow As Long: lRow = lCell.Row
If lRow = fRow Then Exit Sub
.Resize(lRow - fRow).Offset(fRow - .Row + 1).Clear ' .Delete xlShiftUp
End With
End Sub
Related
I am trying to clear all of the contents from columns E through AN for only the rows that have data in Column E (and not continue through the rest of the sheet). I would like the formulas in the cells to stay intact.
Any help greatly appreciated!
Sub ClearJEdetails()
Dim rng As Range
Set rng = Range("e12:AI1048530")
'Selecting only hardcoded data
rng.SpecialCells(xlCellTypeConstants).Select
Selection.ClearContents
End Sub
Sub ClearJEformulas()
Dim rng As Range
Set rng = Range("aj13:Ak1048530")
'Selecting only formulas
rng.SpecialCells(xlCellTypeFormulas).Select
Selection.ClearContents
End Sub
Clear Contents of Filtered Rows in Certain Columns
Adjust the values in the constants section.
Option Explicit
Sub DeleteFilteredEntireRows()
Const wsName As String = "Sheet1"
Const hRow As Long = 1
Const lrCol As String = "E"
Const Cols As String = "E:AN"
Const Criteria As String = "<>" ' non-blanks
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
Dim rCount As Long: rCount = lRow - hRow + 1
Dim scrg As Range: Set scrg = ws.Cells(hRow, lrCol).Resize(rCount)
Dim scdrg As Range: Set scdrg = scrg.Resize(rCount - 1).Offset(1)
scrg.AutoFilter 1, Criteria
Dim vcdrg As Range
On Error Resume Next
Set vcdrg = scdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False
If vcdrg Is Nothing Then Exit Sub
Dim drg As Range: Set drg = Intersect(vcdrg.EntireRow, ws.Columns(Cols))
drg.ClearContents
End Sub
am trying to make my code better, so the first thing I am trying to do is to remove all usage of selects and selection from my code.
The problem am facing is I am unable to get a stable code without using Selection.
PFB code am using to make the selection
Sub findandCopyVisbleCellsinColumn(ByRef wb As Workbook, ByRef ws As Worksheet, ByRef columnNumber As Long)
Dim lrow, lcolumn As Long
With wb
With ws
ws.Activate
Selection.End(xlToLeft).Select
ws.Range(Cells(1, columnNumber).Address).Offset(1, 0).Select
ws.Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
End With
End With
End Sub
PFB Code am using for calling above code and pasting the values
emptyCell = range_End_Method(wb, ws, 3)
Call findandCopyVisbleCellsinColumn(wb, ws1, 7)
ws.Range("C" & emptyCell).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
What I have done until now
With ws
ws.Activate
Selection.End(xlToLeft).Select
lrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lcolumn = ws.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
.Range(.Cells(.Cells(2, columnNumber).Address).Offset(1, 0), lrow, lcolumn).Copy
End With
this is giving an error for invalid property assignment. I suspect its due to assigning cells to cells, Please point me in the right direction.
Thanks in advance.
Copy Visible Cells in a Column
The feedback to my post Function vs Sub(ByRef) was kind of groundbreaking to my understanding of the difference between ByVal and ByRef (and accidentally error handling, too). Basically, to your surprise, you will rarely need ByRef.
Option Explicit
Sub YourPBFCode()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("source")
Dim dws As Worksheet: Set dws = wb.Worksheets("target")
CopyVisibleCellsInColumn sws.Range("G2"), dws.Range("C2")
End Sub
' Just a test (example).
Sub CopyVisibleCellsInColumnTEST()
Const sName As String = "Sheet1"
Const sAddr As String = "A2"
Const dName As String = "Sheet2"
Const dAddr As String = "A2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sAddr)
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim difCell As Range: Set difCell = dws.Range(dAddr)
CopyVisibleCellsInColumn sfCell, difCell
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Copies the visible cells of a one-column range to another
' one-column range. The source range is defined by its first cell
' and the last cell in its column of its worksheet's used range.
' The column of the destination range is defined by its first
' initial cell. The first row of the destination range
' will be the row of the last non-empty cell in the column
' increased by one aka the first available row.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CopyVisibleCellsInColumn( _
ByVal SourceFirstCell As Range, _
ByVal DestinationInitialFirstCell As Range)
If SourceFirstCell Is Nothing Then Exit Sub
If DestinationInitialFirstCell Is Nothing Then Exit Sub
' Create a reference to the Source Range ('srg').
Dim sfCell As Range: Set sfCell = SourceFirstCell.Cells(1)
Dim srg As Range: Set srg = RefVisibleCellsinColumn(sfCell)
If srg Is Nothing Then Exit Sub ' no data
' Create a reference to the Destination Range ('drg').
Dim difCell As Range: Set difCell = DestinationInitialFirstCell.Cells(1)
Dim dfCell As Range: Set dfCell = RefFirstAvailableCellInColumn(difCell)
If dfCell Is Nothing Then Exit Sub ' no available cells
Dim srCount As Long: srCount = srg.Cells.Count
If srCount > dfCell.Worksheet.Rows.Count - dfCell.Row + 1 Then
Exit Sub ' does not fit
End If
Dim drg As Range: Set drg = dfCell.Resize(srCount)
' Write values from the Source Range to the Destination Array ('dData').
Dim dData As Variant: dData = GetColumnMultiRange(srg)
' Write values from the Destination Array to the Destination Range.
drg.Value = dData
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the visible cells of the range
' at the intersection of the one-column range from the first cell
' of a range ('FirstCellRange') to the bottom-most worksheet cell,
' and the used range of the worksheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefVisibleCellsinColumn( _
ByVal FirstCellRange As Range) _
As Range
If FirstCellRange Is Nothing Then Exit Function
Dim fCell As Range: Set fCell = FirstCellRange.Cells(1)
Dim wsrCount As Long: wsrCount = fCell.Worksheet.Rows.Count
Dim crg As Range: Set crg = fCell.Resize(wsrCount - fCell.Row + 1)
On Error Resume Next
Set RefVisibleCellsinColumn = _
Intersect(crg.Worksheet.UsedRange, crg).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In the one-column range ('crg') from the first cell ('fCell')
' of a range ('FirstCellRange') to the bottom-most worksheet cell,
' creates a reference to the first available cell
' i.e. the cell below the last non-empty cell ('lCell.Offset(1)').
' If the one-column range ('crg') is empty,
' the first cell ('fCell') is also the first available cell.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefFirstAvailableCellInColumn( _
ByVal FirstCellRange As Range) _
As Range
If FirstCellRange Is Nothing Then Exit Function
Dim fCell As Range: Set fCell = FirstCellRange.Cells(1)
Dim wsrCount As Long: wsrCount = fCell.Worksheet.Rows.Count
Dim crg As Range: Set crg = fCell.Resize(wsrCount - fCell.Row + 1)
Dim lCell As Range: Set lCell = crg.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then
Set RefFirstAvailableCellInColumn = fCell
Else
If lCell.Row < wsrCount Then
Set RefFirstAvailableCellInColumn = lCell.Offset(1)
End If
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of the first columns of each single range
' of a multi-range in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnMultiRange( _
ByVal ColumnMultiRange As Range) _
As Variant
On Error GoTo ClearError ' too many areas, "RTE '7': Out of memory"
If ColumnMultiRange Is Nothing Then Exit Function
Dim aCount As Long: aCount = ColumnMultiRange.Areas.Count
Dim aData As Variant: ReDim aData(1 To aCount, 1 To 2)
Dim ocData As Variant: ReDim ocData(1 To 1, 1 To 1)
Dim arg As Range
Dim a As Long
Dim arCount As Long
Dim drCount As Long
For Each arg In ColumnMultiRange.Areas
a = a + 1
With arg.Columns(1)
arCount = .Rows.Count
If arCount = 1 Then ' one cell
ocData(1, 1) = .Value
aData(a, 1) = ocData
Else ' multiple cells
aData(a, 1) = .Value
End If
End With
aData(a, 2) = arCount
drCount = drCount + arCount
Next arg
'Debug.Print aCount, arCount, drCount
Dim dData As Variant: ReDim dData(1 To drCount, 1 To 1)
Dim ar As Long
Dim dr As Long
For a = 1 To aCount
For ar = 1 To aData(a, 2)
dr = dr + 1
dData(dr, 1) = aData(a, 1)(ar, 1)
Next ar
Next a
GetColumnMultiRange = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Function
Hard to explain where you've gone wrong with your range selection.
.Range(.Cells(.Cells(2, columnNumber).Address).Offset(1, 0), lrow, lcolumn)
Range is one or more cells in the worksheet.
Cells is a single cell in the worksheet - referenced using the row number and row column or letter. So Cells(1,1) will work, as will Cells(1,"A"). Your code has supplied a complete cell address - so is trying to do Cells("A1").
This is how I'd do it without selecting anything:
Sub Test()
'Copy data from sheet1 to sheet2 in a different workbook.
CopyAndPaste ThisWorkbook.Worksheets("Sheet1"), _
Workbooks("Book4").Worksheets("Sheet2")
'Copy data from sheet1 to sheet2 in workbook that contains this code.
CopyAndPaste ThisWorkbook.Worksheets("Sheet1"), _
ThisWorkbook.Worksheets("Sheet2")
End Sub
Private Sub CopyAndPaste(Source As Worksheet, Target As Worksheet)
Dim LastCell As Range
Set LastCell = GetLastCell(Source)
With Source
'Copies a range from A1 to LastCell and pastes in Target cell A1.
.Range(.Cells(1, 1), LastCell).Copy Destination:=Target.Cells(1, 1)
End With
End Sub
Private Function GetLastCell(ws As Worksheet) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With ws
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set GetLastCell = .Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
Note the actual copy/paste is a single line:
.Range(.Cells(1, 1), LastCell).Copy Destination:=Target.Cells(1, 1)
This copies the range on the Source worksheet from cells A1 (1,1) to whatever range is returned by the GetLastCell function. As that function returns a range object it can be used directly - no need to find the address and pass that separately to another range object.
The copied cells are then pasted to cell A1 on the Target worksheet. As long as you've got the correct sheet reference the code will know which workbook the worksheet belongs to - no need for With wb:With ws - the ws reference already contains the wb reference.
I am working on a macro that uses VBA to complete an index-match function. The vba errors out, saying I have a type mismatch, however I use the same variables earlier in the script in a similar way and that runs with no issues. The lookup values are in another sheet called "Items". The code snippet is below. Any help would be appreciated.
Sub Test_1
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim wb As Workbook
Dim i As Long, j As Long
Dim r As Range, cell As Range, aCell As Range, LastRow As Range
Dim strSearch As String
Set wb = ThisWorkbook
With wb
strSearch = "Column_1"
i = 0
Set LastRow = ws4.Cells(Rows.Count, 1).End(xlUp)
Set aCell = ws4.Rows(1).Find(What:=strSearch, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
For i = LastRow To 2 Step -1
ws4.Cells(i, aCell).Value = WorksheetFunction.Index(wb.Sheets("Items").Range("D:D"), WorksheetFunction.Match(ws4.Cells(i, aCell), wb.Sheets("Items").Range("A:A")))
On Error Resume Next
Next i
Else: 'Do Nothing
End If
End With
End Sub
Application.Match feat. IsNumber (IsError)
This should get you on the right track. Just solve the mystery where you're searching for the value of a cell in one column, returning the associated value of another column, yet using it to overwrite the value in the initial cell which is kind of unusual.
Sub Test_1()
Dim ws As Workbook: Set wb = ThisWorkbook
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet4") ' ???
Dim sws As Worksheet: Set sws = wb.Worksheets("Items")
Dim Header As String: Header = "Column_1"
Dim hCell As Range: Set hCell = dws.Rows(1).Find(Header, _
dws.Rows(1).Cells(dws.Rows(1).Cells.Count), xlFormulas, xlWhole)
If Not hCell Is Nothing Then
Dim hCol As Long: hCol = hCell.Column
Dim LastRow As Long
Set LastRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
Dim lrg As Range: Set lrg = sws.Range("A:A") ' Lookup Range
Dim srg As Range: Set srg = sws.Range("D:D") ' Source Range
Dim cIndex As Long
Dim i As Long
For i = 2 To LastRow
' dws.Cells(i, col) ??? - You usually don't overwrite the value...
cIndex = Application.Match(dws.Cells(i, col).Value, lrg, 0)
If IsNumeric(cIndex) Then
' ... that you were searching for ???
dws.Cells(i, col).Value = srg.Cells(cIndex).Value
End If
Next i
End If
End Sub
I'm writing some VBA to check if a value exists in a column.
lRowStatic = Worksheets("GLMapping_Static").Cells(Rows.Count, 1).End(xlUp).Row
lRow = Worksheets("GLMapping").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow
If IsError(Application.Match(Worksheets("GLMapping").Cells(i, 1).Value, Worksheets("GLMapping_Static").Range(Cells(1, 1), Cells(lRowStatic, 1)), 0)) Then
MsgBox "Its not in the range"
Else
MsgBox "Its in the range"
End If
Next i
I'm confused because this code appears to work well if the "GLMapping_Static" worksheet is currently activated. If the "GLMapping" worksheet is currently activated, then I get a 1004 error.
Any idea what is causing this? I assumed there was a cell reference that didn't include a worksheet name, but I'm not seeing one.
Thanks
Qualifying Objects
The critical part is the expression
Worksheets("GLMapping_Static").Range(Cells(1, 1), Cells(lRowStatic, 1))
where Cells are not qualified so when you choose a different worksheet than GLMapping_Static, Cells will refer to the wrong worksheet resulting in a run-time error.
The first example is illustrating how to fully qualify objects (wb-ws-rg). To simplify, one could say that .Range, .Cells, .Rows, and .Columns belong to a worksheet (object), each .Worksheets belongs to a workbook (object), and each .Workbooks belongs to the Application (object).
The other examples are just showing the benefits of using variables and some possible improvements on other accounts.
The Code
Option Explicit
Sub Humongous()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim lRowStatic As Long
lRowStatic = wb.Worksheets("GLMapping_Static") _
.Cells(wb.Worksheets("GLMapping_Static").Rows.Count, 1).End(xlUp).Row
Dim lRow As Long
lRow = wb.Worksheets("GLMapping") _
.Cells(wb.Worksheets("GLMapping").Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 1 To lRow
If IsError(Application.Match(wb.Worksheets("GLMapping").Cells(i, 1) _
.Value, wb.Worksheets("GLMapping_Static") _
.Range(wb.Worksheets("GLMapping_Static") _
.Cells(1, 1), wb.Worksheets("GLMapping_Static") _
.Cells(lRowStatic, 1)), 0)) Then
MsgBox "Its not in the range"
Else
MsgBox "Its in the range"
End If
Next i
End Sub
Sub Sheeted()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("GLMapping_Static")
Dim sLast As Long: sLast = sws.Cells(sws.Rows.Count, 1).End(xlUp).Row
Dim srg As Range: Set srg = sws.Range(sws.Cells(1, 1), sws.Cells(sLast, 1))
Dim dws As Worksheet: Set dws = wb.Worksheets("GLMapping")
Dim dLast As Long: dLast = dws.Cells(dws.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 1 To dLast
If IsError(Application.Match(dws.Cells(i, 1).Value, srg, 0)) Then
MsgBox "Its not in the range"
Else
MsgBox "Its in the range"
End If
Next i
End Sub
Sub Ranged()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim srg As Range
Dim sLast As Long
With wb.Worksheets("GLMapping_Static")
sLast = .Cells(.Rows.Count, 1).End(xlUp).Row
Set srg = .Range(.Cells(1, 1), .Cells(sLast, 1))
End With
Dim drg As Range
Dim dLast As Long
With wb.Worksheets("GLMapping")
dLast = .Cells(.Rows.Count, 1).End(xlUp).Row
Set drg = .Range(.Cells(1, 1), .Cells(dLast, 1))
End With
Dim dCell As Range
For Each dCell In drg.Cells
If IsNumeric(Application.Match(dCell, srg, 0)) Then
MsgBox "Its in the range"
Else
MsgBox "Its not in the range"
End If
Next i
End Sub
You can do something like this.
Sub TryMe()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws1 = Sheets("GLMapping_Static")
Set ws2 = Sheets("GLMapping")
wb.Activate
ws1.Select
lRowStatic = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow
If IsError(Application.Match(ws2.Cells(i, 1).Value, ws1.Range(Cells(1, 1), Cells(lRowStatic, 1)), 0)) Then
MsgBox "Its not in the range"
Else
MsgBox "Its in the range"
End If
Next i
End Sub
I have developed a working macro in VBA that automatically opens a workbook and then copies the data and pastes it on a table in the workbook I am working on. I perform this task monthly.
The data set varies in rows every month but does not vary in columns.
I am running into issues when the data set in less rows than the previous month and I am forced to manually delete lines that remained in the table because the previous month had more rows.
I was hoping to add to my existing code to automatically delete the old data after pasting the new data.
I perform a manual keystroke of selecting the last row of new data and move down one cell in column A then do a Ctrl+Shift+Down+Right to grab the data and select delete. So essentially that is the task I am trying to replace.
Thanks.
Sub Import_File()
Dim wbSourceData As Workbook
Dim wbDestination As Workbook
Dim wsSourceData As Worksheet
Dim wsDestination As Worksheet
Dim strFName As String
Dim rng As Range
Dim tbl As ListObject
Dim Cl As Long
Dim Rl As Long
Set wbDestination = ThisWorkbook
Set wsDestination = wbDestination.Sheets("DataTab")
strFName = wbDestination.Worksheets("Macros").Range("C2").Value
Set wbSourceData = Workbooks.Open(strFName)
Set wsSourceData = wbSourceData.Worksheets(3)
Set tbl = wsDestination.ListObjects("Data_Report")
tbl.DataBodyRange.ClearContents
With wsSourceData
Cl = .Cells(2, .Columns.Count).End(xlToLeft).Column
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range(.Cells(2, "A"), .Cells(Rl, Cl))
End With
rng.Copy
wsDestination.Range("A4").PasteSpecial xlValues
Application.CutCopyMode = False
wbSourceData.Close SaveChanges:=False
End Sub
Overwrite Data Body Range
It is assumed that only values of the range will be copied.
The Code
Option Explicit
Sub overwriteDataBodyRangeTEST()
Dim rg As Range: Set rg = Range("G2:K11")
Dim tbl As ListObject: Set tbl = DataTab.ListObjects("Data_Report")
overwriteDataBodyRange rg, tbl
End Sub
Sub overwriteDataBodyRange( _
ByVal rg As Range, _
ByVal tbl As ListObject)
With tbl.DataBodyRange
Dim rCount As Long: rCount = rg.Rows.Count
Dim tCount As Long: tCount = .Rows.Count
If rg.Columns.Count = .Columns.Count Then
.Resize(rCount).Value = rg.Value
If rCount < tCount Then
.Resize(tCount - rCount).Offset(rCount).Delete
End If
Else
MsgBox "Different number of columns.", vbCritical, "Fail"
End If
End With
End Sub
EDIT
The following will copy the range to the table overwriting the previous data. If the previous data has more rows, they will be deleted.
Integrated
Option Explicit
Sub Import_File()
' Define Destination Table.
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets("DataTab")
Dim tbl As ListObject: Set tbl = dws.ListObjects("Data_Report")
' Define Source Range.
Dim sName As String: sName = dwb.Worksheets("Macros").Range("C2").Value
Dim swb As Workbook: Set swb = Workbooks.Open(sName)
Dim sws As Worksheet: Set sws = swb.Worksheets(3)
Dim rng As Range
Dim LastRow As Long
Dim LastColumn As Long
With sws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(2, "A"), .Cells(LastRow, LastColumn))
End With
' Copy Source Range to Destination Table.
With tbl.DataBodyRange
Dim tCount As Long: tCount = .Rows.Count
Dim rCount As Long: rCount = rng.Rows.Count
.Resize(rCount).Value = rng.Value ' values only
'rng.Copy .Resize(rCount) ' values, formats, and formulas
If rCount < tCount Then
.Resize(tCount - rCount).Offset(rCount).Delete
End If
End With
' Close Source Workbook (it was just read from).
swb.Close SaveChanges:=False
End Sub