Increasing time difference between data points - excel

I'm trying to make a macro that increases the time between data points as part of automatic data processing, but it currently takes way too long.
One of my sensors logs a data point every 10 seconds, I want to increase this dt to 1 hour. For this I wrote some very simple (inefficient) code (see below) that does work but takes 10-40 minutes to process 1 week of data which is far from ideal.
I've seen recommendations for semi-similar issues to use an array, however I have 0 experience with this and don't know if it's applicable to this goal.
Do While Cells(row + 1, 2).Value <> ""
If Cells(row + 1, 2).Value - Cells(row, 2).Value < 1 / 24.05 Then
Rows(row + 1).Select
Selection.Delete Shift:=xlUp
Else
row = row + 1
End If
Loop
EDIT:
I solved my issue with a slightly edited version of #Damian's code as shown below.
Sub Change_dt()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim target As Single
target = Sheets("Controller").Cells(16, 9).Value
Dim arrSource As Variant
With ThisWorkbook.Sheets("Raw data")
arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array
Dim finalArr As Variant
ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))
.Cells.Delete 'will clean the worksheet
Dim i As Long, x As Long, j As Long, Z As Long
x = 1
Z = 1
For i = 1 To UBound(arrSource)
On Error Resume Next
If arrSource(i + Z, 1) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end the loop once the next row is empty
On Error GoTo 0
'If the next row substracted the first is greater than target both will be copied to the final array
If arrSource(i + Z, 1) - arrSource(i, 1) > target Then
For j = 1 To UBound(arrSource, 2)
finalArr(x, j) = arrSource(i, j)
finalArr(x + 1, j) = arrSource(i + Z, j)
Next j
x = x + 2 'increment 2 on x because you wrote 2 lines
i = i + Z
Z = 1
Else
Z = Z + 1
End If
Next i
'paste the resulting array back to the sheet
.Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr
'eliminate the extra unused rows
i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Rows(i & ":" & .Rows.Count).Delete
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

This should help a lot in your executing time:
Sub Change_dt()
Dim target As Single
target = Sheets("Controller").Cells(16, 9).Value
Dim arrSource As Variant
With ThisWorkbook.Sheets("Raw data")
arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array
Dim finalArr As Variant
ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))
.Cells.Delete 'will clean the worksheet
Dim i As Long, x As Long, j As Long
x = 1
For i = 5 To UBound(arrSource)
On Error Resume Next
If arrSource(i + 1, 2) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end the loop once the next row is empty
On Error GoTo 0
'If the next row substracted the first is greater than 1/24.05 both will be copied to the final array
If Not arrSource(i + 1, 2) - arrSource(i, 2) < target Then
For j = 1 To UBound(arrSource, 2)
finalArr(x, j) = arrSource(i, j)
finalArr(x + 1, j) = arrSource(i + 1, j)
Next j
x = x + 2 'increment 2 on x because you wrote 2 lines
End If
Next i
'paste the resulting array back to the sheet
.Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr
'eliminate the extra unused rows
i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Rows(i & ":" & .Rows.Count).Delete
End With
End Sub

Related

trying to copy a row and the row before it to another sheet based on a value in column A

'this is what I have so far and it is only sending the one row over not the one before it. I don't think the offset code is working.
Sub Macro1()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet1").Range("A1:A" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "CREDIT" Then
xRg(K).Offset(-1, 0).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
You are copying both rows (xRg(K).Offset(-1, 0).EntireRow and xRg(K).EntireRow) to the same destination row Range("A" & J + 1). So the code is copying both rows, but the first copied row is overwritten immediately.
Obvious easy workaround is to increase J twice, once after the first copy (missing) and once after the second (already there). Or Write J + 2 for the second row and increase J by 2 afterwards.
However, you can copy both rows at once:
xRg(K).Offset(-1, 0).Resize(2).EntireRow.Copy _
Destination:=Worksheets("Sheet2").cells(j+1, 1).Resize(2).EntireRow
J = J + 2

VBA formatting table with merged cells

I've got a function which merges cells in table if whole range has the same value (eg. if A1:G1 is equal to A2:B2 it will merge cells like A1&A2, B1&B2 etc. More here: How to check if two ranges value is equal)
Now I would like, to change color on table created by that funcion, like first row (doesn't matter if merged or no) filled with color, second blank etc. but I have no idea whether I should color it with merging function or create another which will detect new table with merged rows as one etc. Below is my code:
Sub test()
Dim i As Long, j As Long, k As Long, row As Long
row = Cells(Rows.Count, 2).End(xlUp).row
k = 1
For i = 1 To row Step 1
If Cells(i, 1).Value = "" Then Exit For
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
k = i + 1
End If
Next i
End Sub
Try:
Option Explicit
Sub test1()
Dim LastColumn As Long, LastRow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To LastRow Step 2
.Range(Cells(i, 1), .Cells(i, LastColumn)).Interior.Color = vbGreen '<- You could change the color
Next i
End With
End Sub
Before:
After:
Edited Solution:
Option Explicit
Sub test1()
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .UsedRange
.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Table1"
.ListObjects("Table1").TableStyle = "TableStyleLight3"
End With
End Sub
Result:
So, after some time I've figured it out by myself. Below is the code:
Dim i As Long, j As Long, k As Long, l As Long, c As Integer
row = Cells(Rows.Count, 2).End(xlUp).row
k = 7
c = 1
For i = 7 To row Step 1
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
Select Case c
Case 0
Range(Cells(k, 1), Cells(k, 3)).Interior.Color = xlNone
c = 1
Case 1
For l = 0 To i - k Step 1
Range(Cells(k + l, 1), Cells(k + l, 3)).Interior.Color = RGB(217, 225, 242)
Next l
c = 0
End Select
k = i + 1
End If
Next i

How to use loop to SUM categories?

I am trying to use a loop with vba to sum values from one worksheet to another. I am struggling with writing my code to match values from Sheet 4 and if the value matches then sum the categories from Sheet 1, if not then skip to the next office. I would also like to exclude certain categories from being included in the SUM loop for example, exclude "Book". Currently my macro is writing to Sheet3. Here is my code:
Option Explicit
Sub test()
Dim a, i As Long, ii As Long, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
a = Sheets("sheet1").Cells(1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not dic.Exists(a(i, 1)) Then dic(a(i, 2)) = dic.Count + 2
If Not .Exists(a(i, 1)) Then
Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
.Item(a(i, 1))(a(i, 2)) = .Item(a(i, 1))(a(i, 2)) + a(i, 3)
Next
ReDim a(1 To .Count + 1, 1 To dic.Count + 1)
a(1, 1) = Sheets("sheet1").[a1]
For i = 0 To dic.Count - 1
a(1, i + 2) = dic.Keys()(i)
Next
For i = 0 To .Count - 1
a(i + 2, 1) = .Keys()(i)
For ii = 2 To UBound(a, 2)
a(i + 2, ii) = .items()(i)(a(1, ii)) + 0
Next
Next
End With
With Sheets("sheet3").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
.EntireColumn.ClearContents
Sheets("sheet1").[a1].Copy .Rows(1)
.Value = a: .Columns.AutoFit: .Parent.Activate
End With
End Sub
This is how the data looks
and this is the output that is desired
In this example, we will use arrays to achieve what you want. I have commented the code so that you shall not have a problem understanding it. However if you still do then simply ask :)
Input
Output
Logic
Find last row and last column of input sheet
Store in an array
Get unique names from Column A and Row 1
Define output array
Compare array to store sum
Create new sheet and output to that sheet
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet, wsNew As Worksheet
Dim tempArray As Variant, OutputAr() As Variant
Dim officeCol As New Collection
Dim productCol As New Collection
Dim itm As Variant
Dim lrow As Long, lcol As Long, totalsum As Long
Dim i As Long, j As Long, k As Long
'~~> Input sheet
Set ws = Sheet1
With ws
'~~> Get Last Row and last column
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
lcol = .Cells(1, Columns.Count).End(xlToLeft).Column
'~~> Store it in a temp array
tempArray = .Range(.Cells(2, 1), .Cells(lrow, lcol)).Value
'~~> Create a unique collection using On error resume next
On Error Resume Next
For i = LBound(tempArray) To UBound(tempArray)
officeCol.Add tempArray(i, 1), CStr(tempArray(i, 1))
productCol.Add tempArray(i, 2), CStr(tempArray(i, 2))
Next i
On Error GoTo 0
End With
'~~> Define you new array which will hold the desired output
ReDim OutputAr(1 To officeCol.Count + 1, 1 To productCol.Count + 1)
'~~> Store the rows and columns in the array
i = 2
For Each itm In officeCol
OutputAr(i, 1) = itm
i = i + 1
Next itm
i = 2
For Each itm In productCol
OutputAr(1, i) = itm
i = i + 1
Next itm
'~~> Calculate sum by comparing the arrays
For i = 2 To officeCol.Count + 1
For j = 2 To productCol.Count + 1
totalsum = 0
For k = LBound(tempArray) To UBound(tempArray)
If OutputAr(i, 1) = tempArray(k, 1) And _
OutputAr(1, j) = tempArray(k, 2) Then
totalsum = totalsum + tempArray(k, 3)
End If
Next k
OutputAr(i, j) = totalsum
Next j
Next i
'~~> Create a new sheet
Set wsNew = ThisWorkbook.Sheets.Add
'~~> Outout the array
wsNew.Range("A1").Resize(officeCol.Count + 1, productCol.Count + 1).Value = OutputAr
End Sub

Write value from 12 column on another worksheet if two conditions in columns 4 and 8 are true

Sub CreateTable()
Dim bf As Boolean
Dim aTable(), aRes()
Dim i As Long, k As Long, n As Long
With Worksheets("DOHADNÉ POLOŽKY") ' List s tabulkou, kde se hleda
i = .Cells(.Rows.Count, "A").End(xlUp).row
aTable = .Range("A1:P" & i).Value ' tabulka do pole
ReDim aRes(1 To i + 1, 1 To 1) ' velikost pole
End With
For i = 1 To UBound(aTable) ' od 1 do poctu radky tabulky
If aTable(i, 1) <> Empty Then ' kdyz neni prazdna
If aTable(i, 4) = "Depo" And aTable(i, 8) = "CZK" Then
aTable(i, 12) = aRes(i, 1): i = i + 1
End If
End If
Next i
' upload vysledku na list do sloupce J
Worksheets("List1").Range("A1").Resize(UBound(aRes), 1).Value = aRes
Range("A1").Select
ActiveCell.FormulaR1C1 = "KUK"
End Sub
Something is wrong. It has no errors, but it doesn't write value in array I think. So the result on Worksheet("List1") is just empty.

How to duplicate preferred columns data in Conditionally one sheet to multiple sheets

In My office five Employee is working for example In my office Employ Entry Exit sheet is dere..
This is Main Sheet
Now my requirement
category wise data copy to this sheet to other sheet but it's do it automatically
Like Example
enter image description here
I hope I am interpreting your question correctly, but please let me know if I have misinterpreted your request.
Try the following code on your sheet:
Sub AutoCopyByName()
Dim Names() As String
Dim i As Long, NumRows As Long, NameRow() As Long
Dim j As Integer, NumNames As Integer
j = 0
NumSites = 0
'''''''''''''''''''''''''''''''''''''''''''
'''COUNT NUMBER OF ROWS WITH INFORMATION'''
'''''''''''''''''''''''''''''''''''''''''''
i = 2 'Standard Counter (counts all non-blank cells)
NumRows = 1 'Number of rows with information
Do While WorksheetFunction.IsText(Sheets("data").Range("A" & i))
If Sheets("data").Range("A" & i) <> " " Then NumRows = NumRows + 1
i = i + 1
Loop
'''''''''''''''''''''''''''
'''COUNT NUMBER OF NAMES'''
'''''''''''''''''''''''''''
For i = 3 To NumRows + 1
If Sheets("data").Cells(i, 1) <> Sheets("data").Cells(i - 1, 1) Then NumNames = NumNames + 1 'Works
Next i
''''''''''''''''''
'''REDIM ARRAYS'''
''''''''''''''''''
ReDim Names(NumNames)
ReDim NameRow(NumNames)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''FINDING THE LOCATION OF EACH NAME IN THE SHEET AND STORING IT IN NameRow ARRAY'''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 2 To NumRows + 1
If Sheets("data").Cells(i, 1) <> Sheets("data").Cells(i - 1, 1) Then
Names(j) = Sheets("data").Cells(i, 1).Value
NameRow(j) = i
j = j + 1
End If
Next i
'''''''''''''''''''''''''''''''''''''''''
'''COPY ENTRIES PER NAME TO EACH SHEET'''
'''''''''''''''''''''''''''''''''''''''''
For i = 0 To NumNames - 1
Worksheets.Add
Worksheets(1).Name = Names(i)
Worksheets("data").Rows(1).Copy
Worksheets(Names(i)).Paste
Worksheets("data").Activate
Worksheets("data").Range(Cells(NameRow(i), 1), Cells(NameRow(i + 1) - 1, 1)).EntireRow.Copy
Worksheets(Names(i)).Activate
Worksheets(Names(i)).Range("A2").Select
Worksheets(Names(i)).Paste
Next i
End Sub
I've used the following as my input sheet

Resources