Loop through worksheets and create tables - excel

I have 10 worksheets.
I want to create a table for each. every table has a different amount of data, ive been using the following code for each, but i was wondering how to do it with a loop.
I would truly apreciate some help :)
Sub table()
Dim sht As Worksheet
Dim lastrow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set sht = Worksheets("m9")
Set StartCell = Range("A1")
lastrow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column
sht.Range(StartCell, sht.Cells(lastrow, LastColumn)).Select
Dim objTable As ListObject
Set objTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
End Sub
Tried the following, but with no luck
Sub loop_test()
Dim i As Integer
Dim ws_num As Integer
Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet
ws_num = ThisWorkbook.Worksheets.Count
For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate
'
Dim lastrow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set StartCell = Range("A1")
lastrow = Cells(Rows.Count, StartCell.Column).End(xlUp).Row
Range(StartCell, Cells(lastrow, LastColumn)).Select
Dim objTable As ListObject
Set objTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
Next
starting_ws.Activate
End Sub

You should avoid Activate and Select statements. The following will loop through all worksheets in the workbook and add a ListObject to each sheet. It will also test to see whether there is an already existing ListObject. If the existing ListObject overlaps with the range that you're going to add the table into to, it will convert it to a range before recreating the ListObject
Sub loop_test()
Dim ws As Worksheet
Dim StartCell As Range, TblRng As Range
Dim LastRow As Long, LastColumn As Long
Dim objTable As ListObject
For Each ws In ThisWorkbook.Sheets
Set objTable = Nothing
With ws
Set StartCell = .Range("A1")
LastRow = .Cells(.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = .Cells(StartCell.Row, .Columns.Count).End(xlToLeft).Column
Set TblRng = .Range(StartCell, .Cells(LastRow, LastColumn))
' Test if table exists on sheet
On Error Resume Next
Set objTable = .ListObjects(1)
On Error GoTo 0
' If table overlaps with TblRng - Convert to Range
If Not Intersect(objTable.Range, TblRng) Is Nothing Then
objTable.Unlist
End If
' Create Table
Set objTable = .ListObjects.Add(xlSrcRange, TblRng, , xlYes)
End With
Next ws
End Sub

Try this. As Zac says, steer clear of activating and selecting and include sheet references.
Sub loop_test()
Dim i As Long 'use Long, integer only goes up to c32k
Dim ws_num As Long
Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet
ws_num = ThisWorkbook.Worksheets.Count
Dim lastrow As Long
Dim LastColumn As Long
Dim StartCell As Range, r As Range
Dim objTable As ListObject
For i = 1 To ws_num
With ThisWorkbook.Worksheets(i) 'don't need to activate
Set StartCell = .Range("A1")
lastrow = .Cells(.Rows.Count, StartCell.Column).End(xlUp).Row
Set r = .Range(StartCell, .Cells(lastrow, LastColumn))
Set objTable = .ListObjects.Add(xlSrcRange, r, , xlYes)
End With
Next i
End Sub

Related

VBA merging different sheets doesn't work

I would like to consolidate several sheets by copying data starting from A40 in each sheet
and pasting in a new worksheet
The code doesn't result in error but nothing is copied
Could you help please
Thanks
Sub merge_cognos()
Dim wb As Workbook
Dim ws As Worksheet
Dim startRow As Long
Dim startcol As Integer
Dim lastCol As Long
Dim lastRow As Long
Set wb = ActiveWorkbook
Set ws_new = ActiveWorkbook.Sheets.Add
For Each ws In wb.Worksheets
If ws.Name <> ws_new.Name Then
startRow = 40
startcol = 1
lastRow = Cells(Rows.Count, startcol).End(xlUp).Row
lastCol = Cells(startRow, Columns.Count).End(xlToRight).Column
'get data from each worksheet and copy it into Master sheet
Range(Cells(startcol, startRow), Cells(lastRow, lastCol)).Copy
ws_new.Paste
End If
Next ws
ws_new.Select
With Selection
.Range("F1", Range("F1").End(xlDown)).Sort Key1:=Range("F1"), Order1:=xlDescending, Header:=xlNo
.Columns("F:F").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End With
End Sub
I revised your code in order to:
avoid use of Select/Selection
reference the proper worksheet at every stage
as follows:
Sub merge_cognos()
Dim wb As Workbook
Dim ws As Worksheet
Dim startRow As Long
Dim startcol As Integer
Dim lastCol As Long
Dim lastRow As Long
Set wb = ActiveWorkbook
Dim ws_new As Worksheet
Set ws_new = wb.Sheets.Add
For Each ws In wb.Worksheets
With ws
If .Name <> ws_new.Name Then
startRow = 40
startcol = 1
lastRow = .Cells(.Rows.Count, startcol).End(xlUp).Row
lastCol = .Cells(startRow, .Columns.Count).End(xlToLeft).Column
'get data from each worksheet and copy it into Master sheet
.Range(.Cells(startRow, startcol), .Cells(lastRow, lastCol)).Copy
With ws_new
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial
End With
End If
End With
Next
With ws_new
.Range("F1", .Range("F1").End(xlDown)).Sort Key1:=.Range("F1"), Order1:=xlDescending, Header:=xlNo
.Columns("F:F").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Loop a Macro Through all Sheets

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

Hiding Multiple Rows with one Command - VBA

I am trying to hide multiple rows in an excel worksheet which are empty using following code however i am getting error message "Argument not optional". What could be wrong in the code?
Sub Attendance_Manday()
Dim sht1 As Worksheet
Dim row_count, col_count As Integer
Dim mainrange As Range
Dim startcell As Range
Set startcell = Range("B1")
Set sht1 = Sheets("Mandays")
row_count = Sheets("Mandays").Cells(Rows.Count, startcell.Column).End(xlUp).Row
col_count = Sheets("Mandays").Cells(startcell.Row, Columns.Count).End(xlToLeft).Offset(1, -2).Column
Set mainrange = sht1.Range(startcell.Address & ":" & sht1.Cells(row_count, col_count).Address)
mainrange.Range.SpecialCells(xlCellTypeBlanks).Rows.Hidden = True
End Sub
Based on your code and assuming first row in your sheet is never empty you could do something like that
Sub Attendance_Manday()
Dim sht1 As Worksheet
Dim row_count As Long, col_count As Long
Dim mainrange As Range
Dim startcell As Range
Set startcell = Range("B1")
Set sht1 = Sheets("Mandays")
row_count = Sheets("Mandays").Cells(Rows.Count, startcell.Column).End(xlUp).Row
col_count = Sheets("Mandays").Cells(startcell.Row, Columns.Count).End(xlToLeft).Offset(1, -2).Column
Set mainrange = sht1.Range(startcell.Address & ":" & sht1.Cells(row_count, col_count).Address)
Dim i As Long
For i = 1 To col_count - 1
mainrange.AutoFilter field:=i, Criteria1:="="
Next i
Dim rg As Range
Set rg = mainrange.SpecialCells(xlCellTypeVisible)
mainrange.AutoFilter
rg.Rows.EntireRow.Hidden = True
rg.Rows(1).EntireRow.Hidden = False
End Sub
An if you turn off screenupdating etc. it should be pretty fast as well

Delete old data in table after copy and paste macro

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

How to write code for copy data if condition is met

code is copying data after every 5 seconds but i want it to copy only if bu8<>0 and if condition is not met then do nothing.
Here is the code
Sub UpdateData()
If Hour(Time) >= 3 And Minute(Time) >= 1 Then
Application.OnTime Now + TimeValue("0:0:5"), "UpdateData", False
Else
Application.OnTime Now + TimeValue("0:0:5"), "UpdateData"
CopyData
End If
End Sub
Sub CopyData()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim cRng As Range
Dim dCol As Long
Set sht1 = ThisWorkbook.Sheets("Sheet1")
Set sht2 = ThisWorkbook.Sheets("Sheet2")
Set cRng = sht1.Range("Bu1:bu8")
dCol = sht2.Cells(2, Columns.Count).End(xlToLeft).Column + 1
sht2.Range(Cells(2, dCol).Address, Cells(8, dCol + 1).Address) = cRng.Value
End Sub
You can do something like this:
Sub CopyData()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim cRng As Range, c As Range
Dim dCol As Long
Set sht1 = ThisWorkbook.Sheets("Sheet1")
Set c = sht1.Range("BU8")
If c.Value <> 0 and Len(c.Value)>0 Then
Set sht2 = ThisWorkbook.Sheets("Sheet2")
Set cRng = sht1.Range("Bu1:bu8")
sht2.Cells(2, Columns.Count).End(xlToLeft) _
.Offset(0, 1).Resize(8 ,1).value = cRng.Value
End If
End Sub

Resources