So I have got 2 listobject that I merge and i'd like to get the data timestamped after they are merged successfully.
It all works out pretty ok, but this little piece of code takes almost 2 minutes to finish.
2020-11-04 10:46:34
2020-11-04 10:48:13
There just has to be a faster way. Any ideas?
(lotarget and losource are declared and assigned listobjects on the same sheet)
Application.ScreenUpdating = false
dtoday = Date
sCreator = Application.UserName
For i = 0 To 350
loTarget.Range(i, 7).Value = dtoday
loTarget.Range(i, 8).Value = sCreator
Next i
Application.ScreenUpdating = True
Column of ListObject
Option Explicit
Sub test()
Application.ScreenUpdating = False
Dim loTarget As ListObject
Set loTarget = Sheet1.ListObjects(1)
Dim dtoday As Date
dtoday = Now ' Now for time, Date for date.
Dim sCreator As String
sCreator = Application.UserName
' For data rows 1 to 350:
' loTarget.DataBodyRange(1, 7).Resize(350).Value = dtoday
' loTarget.DataBodyRange(1, 8).Resize(350).Value = sCreator
' For all data rows:
loTarget.DataBodyRange.Columns(7).Value = dtoday
loTarget.DataBodyRange.Columns(8).Value = sCreator
Application.ScreenUpdating = True
End Sub
You could write all values of a column at once. I assume that loTarget is your listObject. Use something like
Application.Calculation = xlManual
With loTarget.Range
.Range("G2").Resize(.Rows.Count-1, 1).Value = Date
.Range("H2").Resize(.Rows.Count-1, 1).Value = Application.UserName
End With
Application.Calculation = xlAutomatic
I am skipping the top row as this holds likely the column header. Note that "G2" is relative to the table and not the worksheet cell "G2" (unless your table starts as cell "A1").
Maybe speed could also be improved by temporarily deactivating calculation.
Related
For example
if range A14:A200
if A14 = 1 so fill G14 Ok
if A14 = 1 so fill G14 Ok
and so on
For example
if range A14:A200
if A14 = 1 so fill G14 Ok
if A15 = 1 so fill G15 Ok
and so on
you could use the excel formulas:
Sub IFSomething()
With Range("A14:A200") reference the needed range
With .Offset(, 6) ' reference the cells 6 columns to the right of referenced range
.FormulaR1C1 = "=IF(RC[-6]=1,""OK"","""")" ' place a formula in referenced range
.Value = .Value ' leave only values
End With
End With
End Sub
So here is revise solution I hope this resolve your query.
Sub If_loop_test()
Dim x As Integer
For x = 1 To 200
If Range("A" & x).Value = 1 Then
Range("G" & x).Value = "ok"
End If
Next
End Sub
Here is a relatively clean and versatile version.
Remember if you're going to be applying this to large data sets this might be slow. you can fix this by importing the range into an array and iterating through that. your code will go from taking 10 seconds on very large data sets to under a second.
Option Explicit
Sub If_Offset_Value()
Dim WS As Worksheet
Dim RG As Range
Dim CL As Range
Dim CheckVal As Variant
' > Change this to whatever value you're checking for.
CheckVal = 1
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set WS = ThisWorkbook.Worksheets("My WorkSheet Name")
Set RG = WS.Range("A14:A200")
For Each CL In RG.Cells
If CL.Value = CheckVal Then
' > Couple of options here depending on your needs:
' Both options give you the same result, but Offset
' moves left and right if you change RG column,
' whereas column letter referense will stay G
'1) Offset Method
CL.Offset(0, 6).Value = "OK"
'2) Reference Column Letter
WS.Range("G" & CL.Row).Value = "OK"
End If
Next CL
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
let's say i have a worksheet with 5 columns and ~30,000 - two of those columns are timestamp formatted. both the TS columns have ~300 blank cells, which i would like to populate with a dummy TS value (1900-01-01 00:00:00) for later filtering. if i inserted an extra column for an IF statement, the formula would look like this, of course:
=IF(B2="","1900-01-01 00:00:00",B2)
however, i would rather use a macro to loop through both TS columns (let's define that range as B2:B30000, C2:C30000).
any help is much appreciated. thanks!
Hopefully it will solve your issue.
Option Explicit
Sub Fill_In_Value()
'Turn off following processes to speed up code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
Dim i As Long
Dim lRow As Long
Dim Column1 As Long
Dim Column2 As Long
Column1 = 1 '1 = To Column A, this setup is easier to change the column later on
Column2 = 2 '2 = To Column B
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the worksheetname
lRow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'Find the last row in Column A
For i = 2 To lRow 'Loop from row 2 to last row
If ws.Cells(i, Column1) = "" Or ws.Cells(i, "B") = "" Then 'If any of the column A or column B is empty then:
If ws.Cells(i, Column1) = "" Then 'If column A have blank value then:
ws.Cells(i, Column1).Value = "1900-01-01 00:00:00" 'Add dummy value
If ws.Cells(i, Column2) = "" Then 'If column A have blank value, also check column B.
ws.Cells(i, Column2).Value = "1900-01-01 00:00:00" 'Add dummy value
End If
ElseIf ws.Cells(i, Column2) = "" Then 'If Column A is not blank, B should be blank
ws.Cells(i, Column2).Value = "1900-01-01 00:00:00"
End If
End If
Next i
'Turn on following processes to get back to normal state
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Complete") 'Message box to show when code is finished
End Sub
Faster version
Sub Fill_In_Value2()
'Turn off following processes to speed up code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
Dim i As Long
Dim lRow1 As Long
Dim lRow2 As Long
Dim Column1 As Long
Dim Column2 As Long
Column1 = 1 '1 = To Column A, this setup is easier to change the column later on
Column2 = 2 '2 = To Column B
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the worksheetname
lRow1 = ws.Cells(Rows.Count, Column1).End(xlUp).Row 'Find the last row in Column A
lRow2 = ws.Cells(Rows.Count, Column2).End(xlUp).Row 'Find the last row in Column B
ws.Range(Cells(2, Column1), Cells(lRow1, Column1)).SpecialCells(xlCellTypeBlanks).Value = "1900-01-01 00:00:00"
ws.Range(Cells(2, Column2), Cells(lRow2, Column2)).SpecialCells(xlCellTypeBlanks).Value = "1900-01-01 00:00:00"
'Turn on following processes to get back to normal state
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Complete") 'Message box to show when code is finished
End Sub
I am trying to generate a number in A1 in Sheet1 every time the Makro is executed. The number is a combination of the date and a number to be incremented. The final number is to be transferred to Sheet2 in column A where there is not yet data (in this case A1>A2>A3>....)
And this is my attempt in VBA but it does nothing.
Sub incrementInvoiceNumber()
Dim rng_dest As Range
Dim i As Long
Application.ScreenUpdating = False
Sheets("Sheet1").Range("A1").Value = WorksheetFunction.Text(Date, "YYYYMMDD") & WorksheetFunction.Text(Range("A1").Value + 1)
i = 1
Set rng_dest = Sheets("Sheet2").Range("A:A")
Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0
i = i + 1
Loop
Sheets("Sheet2").Range("A" & i).Value = Sheets("Sheet1").Range("A1").Value
Application.ScreenUpdating = True
End Sub
It's not so clear what exactly is making the code not working. I think its that some rages are not called by its parent sheet.
Besides, it's always better to avoid WorksheetFunction if you have VBA function that can do the same thing.
And, finding the last row can be done in a much better way by using End() method.
This is how:
Sub incrementInvoiceNumber()
Dim i As Long
Application.ScreenUpdating = False
Sheets("Sheet1").Range("A1").Value = _
Format(Date, "YYYYMMDD") & Format(Sheets("Sheet1").Range("A1").Value + 1) 'Make sure Sheet1 is the sheet with the value. Fix it if otherwise
With Sheets("Sheet2")
i = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not IsEmpty(.Cells(i, 1)) Then i = i + 1
.Cells(i, 1).Value = Sheets("Sheet1").Range("A1").Value
End With
Application.ScreenUpdating = True
End Sub
Cells(Rows.Count, 1).End(xlUp) means the cell that you will reach if you start from the last cell in column A ("A1048576") and press Ctrl + Up Arrow.
I have an Worksheet_Change macro that hides/unhides rows depending on the choice a user makes in a cell with a data validation list.
The code takes a minute to run. It's looping over c.2000 rows. I'd like it to take closer to a few seconds so it becomes a useful user tool.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Exit the routine early if there is an error
On Error GoTo EExit
'Manage Events
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Declare Variables
Dim rng_DropDown As Range
Dim rng_HideFormula As Range
Dim rng_Item As Range
'The reference the row hide macro will look for to know to hide the row
Const str_HideRef As String = "Hide"
'Define Variables
'The range that contains the week selector drop down
Set rng_DropDown = Range("rng_WeekSelector")
'The column that contains the formula which indicates if a row should
'be hidden c.2000 rows
Set rng_HideFormula = Range("rng_HideFormula")
'Working Code
'Exit sub early if the Month Selector was not changed
If Not Target.Address = rng_DropDown.Address Then GoTo EExit
'Otherwise unprotect the worksheet
wks_DailyPlanning.Unprotect (str_Password)
'For each cell in the hide formula column
For Each rng_Item In rng_HideFormula
With rng_Item
'If the cell says "hide"
If .Value2 = str_HideRef Then
'Hide the row
.EntireRow.Hidden = True
Else
'Otherwise show the row
.EntireRow.Hidden = False
End If
End With
'Cycle through each cell
Next rng_Item
EExit:
'Reprotect the sheet if the sheet is unprotected
If wks_DailyPlanning.ProtectContents = False Then wks_DailyPlanning.Protect (str_Password)
'Clear Events
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
I have looked at some links provided by other users on this website and I think the trouble lies in the fact I'm having to iterate through each row individually.
Is it possible to create something like an array of .visible settings I can apply to the entire range at once?
I'd suggest copying your data range to a memory-based array and checking that, then using that data to adjust the visibility of each row. It minimizes the number of interactions you have with the worksheet Range object, which takes up lots of time and is a big performance hit for large ranges.
Sub HideHiddenRows()
Dim dataRange As Range
Dim data As Variant
Set dataRange = Sheet1.Range("A13:A2019")
data = dataRange.Value
Dim rowOffset As Long
rowOffset = IIf(LBound(data, 1) = 0, 1, 0)
ApplicationPerformance Flag:=False
Dim i As Long
For i = LBound(data, 1) To UBound(data, 1)
If data(i, 1) = "Hide" Then
dataRange.Rows(i + rowOffset).EntireRow.Hidden = True
Else
dataRange.Rows(i + rowOffset).EntireRow.Hidden = False
End If
Next i
ApplicationPerformance Flag:=True
End Sub
Public Sub ApplicationPerformance(ByVal Flag As Boolean)
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
End Sub
Another possibility:
Dim mergedRng As Range
'.......
rng_HideFormula.EntireRow.Hidden = False
For Each rng_Item In rng_HideFormula
If rng_Item.Value2 = str_HideRef Then
If Not mergedRng Is Nothing Then
Set mergedRng = Application.Union(mergedRng, rng_Item)
Else
Set mergedRng = rng_Item
End If
End If
Next rng_Item
If Not mergedRng Is Nothing Then mergedRng.EntireRow.Hidden = True
Set mergedRng = Nothing
'........
to increase perfomance you can populate dictionary with range addresses, and hide or unhide at once, instead of hide/unhide each particular row (but this is just in theory, you should test it by yourself), just an example:
Sub HideHiddenRows()
Dim cl As Range, x As Long
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
x = Cells(Rows.Count, "A").End(xlUp).Row
For Each cl In Range("A1", Cells(x, "A"))
If cl.Value = 0 Then dic.Add cl.Address(0, 0), Nothing
Next cl
Range(Join(dic.keys, ",")).EntireRow.Hidden = False
End Sub
demo:
I have a sheet where all dates are in the wrong timezone. I need to add one hour to all cells formated as dates, but leave the rest intact.
I found this:
Public Function AddHour(ByVal sTime As String) As String
Dim dt As Date
dt = CDate(sTime)
dt = DateAdd("h", 1, dt)
AddHour = Format(dt, "mm/dd/yy h:nnam/pm")
End Function
Now, how do I find the cells with dates in them?
Sub AddHour(ByVal ThisSheet As Worksheet)...
The code below was modified to apply additional information you provided in your comment below.
Option Explicit
Public Sub AddHour()
' 17 Dec 2017
Const FirstColumn As String = "A" ' set as required
Const LastColumn As String = "AV" ' set as required
Dim Ws As Worksheet
Dim Cf As Long, Cl As Long ' first / last column
Dim Dt As Double
Dim Rl As Long ' last used row (in column C)
Dim R As Long, C As Long
Set Ws = Worksheets("AddHour") ' replace with your sheet's name
Application.ScreenUpdating = False
With Ws
Cf = Columns(FirstColumn).Column
Cl = Columns(LastColumn).Column
For C = Cf To Cl
Application.StatusBar = Cl - C + 1 & " columns remaining"
Rl = .Cells(.Rows.Count, C).End(xlUp).Row
For R = 1 To Rl ' start looking in row 1 (amend if necessary)
With .Cells(R, C)
If IsDate(.Value) Then
Dt = .Value
' add 1 hour if there is a Time value in the date
If Dt - Int(Dt) Then .Value = Dt + (1 / 24)
End If
End With
Next R
Stop
Next C
End With
With Application
.ScreenUpdating = True
.StatusBar = False
End With
End Sub
You still have to replace the worksheet name "AddHour" in the code with whatever name your worksheet really has and specify the first and last columns where your dates are. You can change the first row in which the code starts looking for them.
The code presumes that your dates are "true" dates. You can test this by selecting any cell with a date you want to change and set its cell format temporarily to "General". If the date is a "true" date a number will be displayed instead of the date, like 43086.5046489583. If the display in the cell doesn't change upon reformatting then your dates are "Text" and must be treated differently.
If you are absolutely certain, that all dates in your sheet have to be modified you could loop over all cells in your used range and make the adjustments using your function like so:
Sub ChangeDate()
Dim rngDates As Range
Dim varCounter As Variant
Dim dt As Date
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Set rngDates = ThisWorkbook.Worksheets("Tabelle2").UsedRange
'Loop over all cells in range
For Each varCounter In rngDates
'If it's a date, change its value
If IsDate(varCounter.Value) Then
dt = CDate(varCounter.Value)
dt = DateAdd("h", 1, dt)
varCounter.Value = Format(dt, "mm/dd/yy h:nnam/pm")
End If
Next varCounter
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub
Depending on the amount of cells in your used range this might not be very performant.
To improve on that we can read your used range into an array and process it in memory like so:
Sub ChangeDate()
Dim varValues As Variant
Dim lngColumns As Long, lngRows As Long
Dim dt As Date
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
'Read entire range to array
varValues = ThisWorkbook.Worksheets("Tabelle2").UsedRange
'Loop over all "columns"
For lngColumns = 1 To UBound(varValues, 1)
'Loop over all "rows" in that "column"
For lngRows = 1 To UBound(varValues, 2)
If IsDate(varValues(lngColumns, lngRows)) Then
dt = CDate(varValues(lngColumns, lngRows))
dt = DateAdd("h", 1, dt)
varValues(lngColumns, lngRows) = Format(dt, "mm/dd/yy h:nnam/pm")
End If
Next lngRows
Next lngColumns
'Overwrite usedRange with array
ThisWorkbook.Worksheets("Tabelle2").UsedRange = varValues
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub
This should be quiet performant regardless of the amount of data you're processing.
It goes without saying that this might not account for everything without having seen your workbook and has to be thoroughly tested.