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
Related
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
Anyone have a macro to paste to multiple ranges in the same sheet?
Trying to get values into every other column'
Sub CopySelections()
Set cellranges = Application.Selection
Set ThisRng = Application.InputBox("Select a destination cell", "Where to paste slections?", Type:=8)
For Each cellrange In cellranges.Areas
cellrange.Copy ThisRng.Offset(i)
i = i + cellrange.Rows.CountLarge
Next cellrange
End Sub
Maybe this?
Sub Add_Spaces()
Dim ICount As Integer
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Dim wb As Workbook
Set wb = ActiveWorkbook
Set Sheet1 = wb.Worksheets("Sheet1")
Set Sheet2 = wb.Worksheets("Sheet2")
Dim IStart As Integer
Dim copyz As Integer
Dim destinationz As Integer
ICount = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
IStart = 1
destinationz = 1
For copyz = 1 To ICount Step IStart
Sheet1.Select
Columns(copyz).Select
Selection.Copy
Sheet2.Select
Columns(destinationz).Select
Sheet2.Paste
destinationz = destinationz + 2
Next copyz
End Sub
Before:
After:
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
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
I have information in a whole lot of worksheets in workbook Wb1 and this information is always in range F11:F500 I want to transfer this information into one sheet in workbook wb in column A. See code below. I receive the error
at this line rng2.Paste
Option Explicit
Sub NameRisk()
' Copy and paste
Dim wb1 As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim rng As Range
Dim c As Range
Dim lastrow As Long
Dim rng2 As Range
Set wb1 = Application.Workbooks("COMBINED ADD.xls")
Set wb = Application.Workbooks("NameRiskXtract.xlsm")
Set ws = wb.Worksheets("Sheet1")
For Each ws1 In wb1.Sheets
Set rng = Range("F11:F500")
For Each c In rng
If c.Value <> "" Then
c.Copy
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Set rng2 = ws.Range("A" & lastrow)
rng2.Paste
End With
End If
Next c
Next ws1
End Sub
Range("F11:F500") should have a parent worksheet; I'm guessing it is ws1. You may be cancelling the Copy operation. Better to Copy with a destination.
...
For Each ws1 In wb1.Sheets
Set rng = ws1.Range("F11:F500")
For Each c In rng
If c.Value <> "" Then
c.Copy destination:=ws.Cells(ws.Rows.Count, "A").End(xlUp).offset(1, 0)
End If
Next c
Next ws
...
You are still in your with statement. try:
For Each ws1 In wb1.Sheets
Set rng = Range("F11:F500")
For Each c In rng
If c.Value <> "" Then
c.Copy
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Set rng2 = .Range("A" & lastrow) " <--- removed ws
rng2.Paste
End With
End If
Next c
Next ws1
You may also want to avoid copy/paste entirely and use this snippet instead:
For Each ws1 In wb1.Sheets
For Each c In ws1.Range("F11:F500")
If c.Value <> "" Then ws.Range("A" & ws.Cells(.Rows.Count, "A").End(xlUp).Row + 1).value = c.value
Next c
Next ws1