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​
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
This should do it in a single loop :
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
 For i = 1 To UBound(DateTimev, 1) - 1
   If DateTimev(i, 1) <> DateTimev(i + 1, 1) Then
    Value2(i, 1) = Value1(i, 1) - sumv
    sumv = 0
   Else
    sumv = sumv + Value2(i, 1)
   End If
 Next i
 
Range(Cells(2, 6), Cells(lastrow, 6)) = Value2 ' just to testthe result
 
End Sub
 
Upvote 0
On further testing Offthelip, it just adds the difference to the last value not the largest of the value2's?
 
Upvote 0
Sorry I misunderstood what you wanted , I will have a think about it
 
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

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

Data = Source_Rng.value

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
            End If
          
        End With
      
    Next Key

End With

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

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

Source_Rng.Columns(6).Value2 = Final

End Sub
 
Upvote 0
Solution
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

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

Data = Source_Rng.value

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
            End If
         
        End With
     
    Next Key

End With

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

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

Source_Rng.Columns(6).Value2 = Final

End Sub
Click to expand...
You should also dim a string variable named current_key
 
Upvote 0
Try this modification to my orginal code:
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
   Else
    If Value2(i, 1) > maxv Then
     maxv = Value2(i, 1)
     maxi = i
    End If
   End If
 Next i
 
Range(Cells(2, 6), Cells(lastrow, 6)) = Value2
 
End Sub
 
Upvote 0
thank you MoshiM, that works perfectly and is fast. I will use.

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.

Both thanks for your help, i have learned a lot. Apology for the late reply to your posts.

Regards

taz
 
Upvote 0
Hi MoshiMI,

One final thing how can i add to your code so that as well as adding a column that shows the new value it also adds a second column that shows the value added or subtracted
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Formula Help.
Replies
3
Views
105
Fluff
Fluff
S
  • Solved
Average in excel
Replies
3
Views
82
etaf
etaf
C
  • Solved
Extract Dates from 2 columns
Replies
2
Views
333
Peter_SSs
Peter_SSs
C
  • Question
Ordinary Hours or Penalty Shift
Replies
0
Views
98
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
173
harzer
H

Forum statistics

Threads
1,215,430
Messages
6,124,853
Members
449,194
Latest member
HellScout

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