Help with a Loop

T

th081

Board Regular
Joined
Mar 26, 2006
Messages
98
Office Version
  1. 365
Platform
  1. Windows
Hi,

I need help with a loop or a steer if there is a better way. I have a table i have where i have imported each column into a array so the first one is DateTime(i, 1) etc.

I need to correct the value 2 where they do not sum up to value 1 by adding or removing the difference from the largest value 2. So the first 4 rows would be unchanged, in the second 4 rows the 1.7981 would be amended to 1.7982 to match the 2.52.

I was going to do a loop to loop through the unique date/time then loop through unique IDs, then loop through unique name, then loop through unique Value1 and where a row matched sum up value2 and amend as need be.

However that will take a long time, does anyone have a steer what other technique i could use to find a match and amend in a large amount of data?

REgards

Taz

Date/TimeIDNameValue1Value 2
12/06/2021 16:30​
1​
NF
9.85​
1​
12/06/2021 16:30​
1​
NF
9.85​
1.8686​
12/06/2021 16:30​
1​
NF
9.85​
3.505​
12/06/2021 16:30​
1​
NF
9.85​
3.4764​
12/06/2021 17:30​
9​
NF
2.52​
0​
12/06/2021 17:30​
9​
NF
2.52​
0.7218​
12/06/2021 17:30​
9​
NF
2.52​
0​
12/06/2021 17:30​
9​
NF
2.52​
1.7981​
12/06/2021 18:00​
1​
GF
9.85​
0​
12/06/2021 18:00​
1​
GF
9.85​
4.005​
12/06/2021 18:00​
1​
GF
9.85​
0​
12/06/2021 18:00​
1​
GF
9.85​
5.845​
12/06/2021 18:30​
9​
GF
14​
0​
12/06/2021 18:30​
9​
GF
14​
4.1535​
12/06/2021 18:30​
9​
GF
14​
0​
12/06/2021 18:30​
9​
GF
14​
9.846​
 
Sort by date Sort by votes
th081 said:
Offthelip, thanks for your help your code is fractionally faster than the dictionary but the values that is changed is not always the largest value or at least the first one was not but the second was.
Click to expand...
To fix that probelm is very easy just add one line:
VBA Code: 
Sub test()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
DateTimev = Range(Cells(2, 1), Cells(lastrow, 1))
ID = Range(Cells(2, 2), Cells(lastrow, 2))
Value1 = Range(Cells(2, 4), Cells(lastrow, 4))
Value2 = Range(Cells(2, 5), Cells(lastrow, 5))

 sumv = 0
 maxv = 0
 maxi = 0
 For i = 1 To UBound(DateTimev, 1) - 1
   sumv = sumv + Value2(i, 1)
   If DateTimev(i, 1) <> DateTimev(i + 1, 1) Then
    Value2(maxi, 1) = Value2(maxi, 1) - (Value1(i, 1) - sumv)
    sumv = 0
    maxv = 0   ' add this line
   Else
    If Value2(i, 1) > maxv Then
     maxv = Value2(i, 1)
     maxi = i
    End If
   End If
 Next i
 
Upvote 0

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
this code should add the extra column too:
VBA Code: 
Sub test()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
DateTimev = Range(Cells(2, 1), Cells(lastrow, 1))
ID = Range(Cells(2, 2), Cells(lastrow, 2))
Value1 = Range(Cells(2, 4), Cells(lastrow, 4))
Value2 = Range(Cells(2, 5), Cells(lastrow, 6))   ' change this linke to add an extra column

 sumv = 0
 maxv = 0
 maxi = 0
 For i = 1 To UBound(DateTimev, 1) - 1
   sumv = sumv + Value2(i, 1)
   If DateTimev(i, 1) <> DateTimev(i + 1, 1) Then
    Value2(maxi, 1) = Value2(maxi, 1) - (Value1(i, 1) - sumv)
    Value2(maxi, 2) = -(Value1(i, 1) - sumv) ' add this line to add columnnn 
    sumv = 0
    maxv = 0   ' add this line
   Else
    If Value2(i, 1) > maxv Then
     maxv = Value2(i, 1)
     maxi = i
    End If
   End If
 Next i
End Sub
 
Upvote 0
VBA Code: 
Sub booo()

Dim Data() As Variant, DD As Object, T As Long, diff As Double, Source_Rng As Range, _
Final() As Variant, Key As Variant, current_key As String

With ActiveSheet.UsedRange
    Set Source_Rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count))
End With

Data = Source_Rng.Value

ReDim Preserve Data(LBound(Data, 1) To UBound(Data, 1), LBound(Data, 2) To UBound(Data, 1) + 1)

Set DD = CreateObject("Scripting.Dictionary")

For T = LBound(Data, 1) To UBound(Data, 1)
  
    current_key = Data(T, 1) & Data(T, 2) & Data(T, 3)
  
    With DD
  
        If Not .Exists(current_key) Then
      
            .Add current_key, CreateObject("Scripting.Dictionary")
          
            With .Item(current_key)
                .Add "V1", Data(T, 4)
                .Add "Current Max", T
            End With
          
        End If
      
        With .Item(current_key)
          
            .Add CStr(T), Data(T, 5)
          
            .Item("Current Sum") = Data(T, 5) + .Item("Current Sum")
          
            If Data(T, 5) > Data(.Item("Current Max"), 5) Then
                .Item("Current Max") = T
            End If
          
        End With
      
    End With
  
Next T

With DD

    For Each Key In .Keys()

        With .Item(Key)
          
            diff = .Item("V1") - .Item("Current Sum")
          
            If Not diff = 0 Then
                T = .Item("Current Max")
                Data(T, 5) = Data(T, 5) + diff
                Data(T, 6) = diff
            End If
          
        End With
      
    Next Key

End With

ReDim Final(1 To UBound(Data, 1), 1 To 2)

For T = LBound(Data, 1) To UBound(Data, 1)
    Final(T, 1) = Data(T, 5)
    Final(T, 2) = Data(T, 6)
Next T

With Source_Rng.Columns(6)
    .Resize(.Rows.Count, 2).Value2 = Final
End With

End Sub
 
Upvote 0
MoshiM said:
VBA Code: 
Sub booo()

Dim Data() As Variant, DD As Object, T As Long, diff As Double, Source_Rng As Range, _
Final() As Variant, Key As Variant, current_key As String

With ActiveSheet.UsedRange
    Set Source_Rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count))
End With

Data = Source_Rng.Value

ReDim Preserve Data(LBound(Data, 1) To UBound(Data, 1), LBound(Data, 2) To UBound(Data, 1) + 1)

Set DD = CreateObject("Scripting.Dictionary")

For T = LBound(Data, 1) To UBound(Data, 1)
 
    current_key = Data(T, 1) & Data(T, 2) & Data(T, 3)
 
    With DD
 
        If Not .Exists(current_key) Then
     
            .Add current_key, CreateObject("Scripting.Dictionary")
         
            With .Item(current_key)
                .Add "V1", Data(T, 4)
                .Add "Current Max", T
            End With
         
        End If
     
        With .Item(current_key)
         
            .Add CStr(T), Data(T, 5)
         
            .Item("Current Sum") = Data(T, 5) + .Item("Current Sum")
         
            If Data(T, 5) > Data(.Item("Current Max"), 5) Then
                .Item("Current Max") = T
            End If
         
        End With
     
    End With
 
Next T

With DD

    For Each Key In .Keys()

        With .Item(Key)
         
            diff = .Item("V1") - .Item("Current Sum")
         
            If Not diff = 0 Then
                T = .Item("Current Max")
                Data(T, 5) = Data(T, 5) + diff
                Data(T, 6) = diff
            End If
         
        End With
     
    Next Key

End With

ReDim Final(1 To UBound(Data, 1), 1 To 2)

For T = LBound(Data, 1) To UBound(Data, 1)
    Final(T, 1) = Data(T, 5)
    Final(T, 2) = Data(T, 6)
Next T

With Source_Rng.Columns(6)
    .Resize(.Rows.Count, 2).Value2 = Final
End With

End Sub
Click to expand...
I just realized that I had a needless step. Remove
VBA Code: 
.Add CStr(T), Data(T, 5)
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Formula Help.
Replies
3
Views
59
Fluff
Fluff
S
  • Solved
Average in excel
Replies
3
Views
63
etaf
etaf
C
  • Solved
Extract Dates from 2 columns
Replies
2
Views
309
Peter_SSs
Peter_SSs
C
  • Question
Ordinary Hours or Penalty Shift
Replies
0
Views
74
ChetanPuri
C
H
  • Solved
Copy the first line and paste it at the start of all subsequent sheets in the same tab
Replies
4
Views
162
harzer
H

Forum statistics

Threads
1,214,920
Messages
6,122,279
Members
449,075
Latest member
staticfluids

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top