Page 4 of 5 FirstFirst ... 2345 LastLast
Results 31 to 40 of 47

Thread: Should this code be written differently? Takes way longer than sorting each sheet manually

  1. #31
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,881
    Post Thanks / Like
    Mentioned
    72 Post(s)
    Tagged
    7 Thread(s)

    Default Re: Should this code be written differently? Takes way longer than sorting each sheet manually

    Thanks for the info
    - glad the code is doing what you want
    - reckon I can speed it up slightly
    - will update the thread later today after testing a few things
    Last edited by Yongle; Jul 25th, 2019 at 01:58 AM.

  2. #32
    Board Regular
    Join Date
    May 2019
    Posts
    54
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Should this code be written differently? Takes way longer than sorting each sheet manually

    One other thing that may not be important. I wasn't sure if you wanted all the code put in one module or in 3 separate modules.

    I put them all in one module and got errors. I put them in 3 separate modules and ran perfect. Don't know if that would have anything to do with speed.

    If it was to go into one module, maybe I did something wrong. Putting them in 3 modules, one macro shows up.....strat919.

  3. #33
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,881
    Post Thanks / Like
    Mentioned
    72 Post(s)
    Tagged
    7 Thread(s)

    Default Re: Should this code be written differently? Takes way longer than sorting each sheet manually

    Try this version
    - it should be considerable faster
    - duplicate co-ordinates are removed at the outset
    - array is now reduced to 4 columns (ie a pair of co-ordinates without distances
    - distances are now calculated in the worksheet by formula and immediately overwritten with the value


    Use a NEW workbook
    EVERYTHING goes in ONE module

    Code:
    'this goes at TOP of module before any  procedures
    
        Option Explicit
        Private List() As Variant, Pairs() As Double
        Const Limit As Long = 1000000
        Private PairCount As Long, ResultsCount As Long, LimitCount As Long
        Dim Results As Worksheet, Data As Worksheet, t As Double
     
    'procedures
    
    Sub Strat919_Version2()
    t = Timer
        Application.ScreenUpdating = False
        ResultsCount = InputBox("How many items to output ?", "User choice", 100)
        Call GeneratePairs
        Call GenerateResults
    
    MsgBox "Running time " & vbCr & Round((Timer - t) / 60, 1) & " minutes"
    End Sub
    
    Private Sub GeneratePairs()
        Dim a As Long, b As Long, c As Long, r As Long
        Set Data = ActiveSheet
    
    'remove duplicate co-ordinates and place remaining values in array
        Data.Range("A:B").RemoveDuplicates Columns:=Array(1, 2)
        List = Data.Range("A1", Data.Range("A" & Data.Rows.Count).End(xlUp)).Resize(, 2)
        PairCount = (UBound(List) ^ 2 - UBound(List)) / 2
        ReDim Pairs(1 To PairCount, 1 To 4)
        
    'place paired values in array
            For a = 1 To UBound(List)
                For b = 1 To UBound(List)
                    If b < a Then
                        r = r + 1
                        Pairs(r, 1) = List(a, 1)
                        Pairs(r, 2) = List(a, 2)
                        Pairs(r, 3) = List(b, 1)
                        Pairs(r, 4) = List(b, 2)
                    End If
                Next b
            Next a
    End Sub
    
    Private Sub GenerateResults()
        Dim r2  As Long, r1 As Long, c As Long, Remainder As Long
    'insert new worksheet
        Set Results = Sheets.Add(before:=Sheets(1))
        Results.Name = "Results " & Format(Now, "yymmdd h.mm am/pm")
    'how many times to move subsets of values?, how many items in last subset?
        LimitCount = WorksheetFunction.RoundDown(PairCount / Limit, 0)
        Remainder = PairCount Mod Limit
    'move each subset in sequence
        r1 = 1
        For c = 1 To LimitCount
            r2 = r2 + Limit
            Call MoveSubset(r1, r2)
            r1 = r1 + Limit
        Next c
        If Remainder > 0 Then
            r2 = r2 + Remainder
            Call MoveSubset(r1, r2)
        End If
    End Sub
    
    Private Sub MoveSubset(firstItem As Long, lastItem As Long)
       
        Dim rTemp As Long, r As Long, c As Long, tempArr()
        Const f = "= 6371 * ACOS(COS(RADIANS(90 - A1)) * COS(RADIANS(90 -C1)) + SIN(RADIANS(90 - A1)) * SIN(RADIANS(90 - C1)) * COS(RADIANS(B1 -D1))) / 1.609"
        ReDim tempArr(1 To lastItem - firstItem + 1, 1 To 4)
        
    'move to temp array
        For r = firstItem To lastItem
            rTemp = rTemp + 1
            For c = 1 To 4
                tempArr(rTemp, c) = Pairs(r, c)
            Next c
        Next r
    'create space for new rows
        Results.Rows("1").Resize(UBound(tempArr)).Insert Shift:=xlDown
    'write to worksheet and calculate distances
        With Results.Range("E1").Resize(UBound(tempArr))
            .Offset(, -4).Resize(, 4).Value = tempArr
            .Formula = f
            .Value = .Value
        End With
    'sort and clear values not required
        Results.Range("A:E").Sort Key1:=Results.Range("E1"), Order1:=xlAscending, Header:=xlNo
        Results.Range("A1").Offset(ResultsCount).Resize(Limit, 5).ClearContents
    End Sub
    Last edited by Yongle; Jul 25th, 2019 at 09:09 AM.

  4. #34
    Board Regular
    Join Date
    May 2019
    Posts
    54
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Should this code be written differently? Takes way longer than sorting each sheet manually

    It dramatically reduced the time!

    4500 entries was 5 min. initially, 3.5 min. with your version1 and 1.5 min. with version2

    12,500 entries was 24 min. version1 and now only 7.6 min with version2

    Only thing I see that needs to be changed is exact duplicates ( 0 in the distance column) need to be included in distance list. In version1 they showed up. There would never be a case where 2 users would add the exact coordinates... but if a single user were to think he didn't enter it correctly or that his coordinates weren't added in time... he may add the same coordinates a second time. So I need to be able to see the the 0 distances also.

    Something I'm not sure of. The way I had intended to run the macro.... open the blank workbook with the code, copy all coordinates from the running coordinate master.
    Then run the macro and see if I need to contend with any duplicates coordinates. Delete them out of the master list, save, and then close the workbook with your code without saving. I am not running your code in the master as there are many other columns of info. Then run your code once a week when I update the master with new coordinates. I don't know if you assumed that I would be saving the workbook with your code each time, adding the newest coordinates, and somehow your code knows what has already been compared and only compares the new coordinates that I have added. I don't think this is the case.... but not positive.

    Hope all that makes sense

    For anybody else who produced some code in the Yongle code.... that has helped me out, thank you also
    Last edited by strat919; Jul 25th, 2019 at 11:26 AM.

  5. #35
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,881
    Post Thanks / Like
    Mentioned
    72 Post(s)
    Tagged
    7 Thread(s)

    Default Re: Should this code be written differently? Takes way longer than sorting each sheet manually

    What the code does
    1. Removes duplicate co-ordinates from the list, leaving unique list of co-ordinates
    2. For each co-ordinate it creates ONE pairing with every co-ordinate EXCEPT itself

    Example: 4 co-ordinates
    London
    Manchester
    Hull
    Bristol

    Created - pairings with distances calculated (6)
    London \ Manchester
    London \ Hull
    London \ Bristol
    Manchester \ Hull
    Manchester \ Bristol
    Hull \ Bristol

    Not Created - Zero distances (4)

    London \ London
    Manchester \ Manchester
    Hill \ Hull
    Bristol \ Bristol

    Not Created - same distance in opposite direction (6)

    Manchester \ London
    Hull \ London
    Bristol \ London
    Hull \ Manchester
    Bristol \ Manchester
    Bristol \ Hull


    Q Are you saying that you want Zero distances included in results sheet?
    Last edited by Yongle; Jul 25th, 2019 at 01:10 PM.

  6. #36
    Board Regular
    Join Date
    May 2019
    Posts
    54
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Should this code be written differently? Takes way longer than sorting each sheet manually

    Yes.... Zero distances included in results sheet.

    Thanks for the info above
    Last edited by strat919; Jul 25th, 2019 at 01:43 PM.

  7. #37
    Board Regular
    Join Date
    May 2019
    Posts
    54
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Should this code be written differently? Takes way longer than sorting each sheet manually

    Also forgot to mention, the cpu usage reaches 28% in excel....way better.

    I tried to edit the code to remove the duplicate deletion, but always got errors....lol.

    So everything is PERFECT except the Zero distances need to be included in the results sheet. There would hardly ever be any.

  8. #38
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,881
    Post Thanks / Like
    Mentioned
    72 Post(s)
    Tagged
    7 Thread(s)

    Default Re: Should this code be written differently? Takes way longer than sorting each sheet manually

    I tried to edit the code to remove the duplicate deletion, but always got errors....lol.
    Did you amend the size of array Pairs to match the increased number of items you were telling VBA to put inside it ?
    - to save memory etc, the code limits the size of the array to only what is required

    EXPLANATION
    If every possible combination is allowed
    - total number of pairings would be no of co-ordinates X no of co-ordinates
    - with 4 co-ordinates (example in post#35) 4 X 4 = 16
    - the calculation of PairCount is determined by what is being EXCLUDED from this loop
    Code:
            
    For a = 1 To UBound(List)
     For b = 1 To UBound(List)
    
     Next b
    Next a
    
    - unwanted "opposite" direction pairings are excluded (ie 6 pairings in our 4 X 4 example)
    - the generic formula to exclude those particular unwanted duplications is ( n X (n + 1) ) / 2 [where n = no of co-ordinates]
    - in our 4 X 4 example, that formula returns ( 4 X (4 + 1 ) ) / 2 = 10

    CODE AMENDMENTS REQUIRED
    - 2 lines to change in GeneratePairs

    determine size of array Pairs by replacing
    Code:
       PairCount = (UBound(List) ^ 2 - UBound(List)) / 2
    with
    Code:
       PairCount = (UBound(List) * (UBound(List) + 1)) / 2
    amend what is placed in array Pairs by replacing
    Code:
      If b < a Then
    with
    Code:
      If b <= a Then
    Last edited by Yongle; Jul 25th, 2019 at 11:49 PM.

  9. #39
    Board Regular
    Join Date
    May 2019
    Posts
    54
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Should this code be written differently? Takes way longer than sorting each sheet manually

    Just returned from going out of town.

    I replaced the above code and it returned a lot of zero distance values

    I placed 500 initial entries, set it for 100 items to output, and it returned 100 zero distances. There are no duplicate pairs in the 500 entries.

    I'm not sure what it is doing.

    The version1 was perfect, except not returning zero distances if any

    Maybe if you could post the entire code with your changes, I changed the code exactly as above, but who knows. I understand some of what's going on, but it still looks like Chinese to me......lol.

    Thanks again and again another time

  10. #40
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,881
    Post Thanks / Like
    Mentioned
    72 Post(s)
    Tagged
    7 Thread(s)

    Default Re: Should this code be written differently? Takes way longer than sorting each sheet manually

    Yes.... Zero distances included in results shee
    The code is doing what I expected - it is now including all zero distances

    4 co-ordinates (as in post#35)
    Excel 2016 (Windows) 32 bit
    A
    B
    C
    D
    1
    51.5074
    0.1278
    London
    2
    53.4808
    2.2426
    Manchester
    3
    53.7676
    0.3274
    Hull
    4
    51.4545
    2.5879
    Bristol
    Sheet: Sheet1

    Returns 4 zero distances and 6 unique non-zero distances
    Excel 2016 (Windows) 32 bit
    A
    B
    C
    D
    E
    F
    G
    1
    51.5074
    0.1278
    51.5074
    0.1278
    0.00
    London London
    2
    53.7676
    0.3274
    53.7676
    0.3274
    0.00
    Hull Hull
    3
    51.4545
    2.5879
    51.4545
    2.5879
    0.00
    Bristol Bristol
    4
    53.4808
    2.2426
    53.4808
    2.2426
    0.00
    Manchester Manchester
    5
    53.7676
    0.3274
    53.4808
    2.2426
    80.96
    Hull Manchester
    6
    51.4545
    2.5879
    51.5074
    0.1278
    105.94
    Bristol London
    7
    51.4545
    2.5879
    53.4808
    2.2426
    140.79
    Bristol Manchester
    8
    53.7676
    0.3274
    51.5074
    0.1278
    156.42
    Hull London
    9
    53.4808
    2.2426
    51.5074
    0.1278
    162.82
    Manchester London
    10
    51.4545
    2.5879
    53.7676
    0.3274
    185.86
    Bristol Hull
    Sheet: Results 190727 6.32 am


    I think that you want some zero distances but not others but I am not sure which ones
    - if that is the case, then we need put the ones that you want into an array and remove the others
    - how do we identify the ones that you do want ?
    - are they the newly added co-ordinates each time?

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •