VBA to put items in Chronological Order

G

Glasgowsmile

Active Member
Joined
Apr 14, 2018
Messages
280
Office Version
  1. 365
Platform
  1. Windows
I'm trying to shift out old data when new data is added and then compare the dates to see where the new data should be placed.

Right now my big issue is the first If statement in the VBA. The worksheet has an IF to check those criteria and it's true by time I get to that part of the VBA code but that first IF statement isn't executing and I don't understand why.

VBA Code: 
Sub ImportChrono()
   
    NewBA = Sheet1.Range("B2").Value
    PBA = Sheet1.Range("D2").Value
    BA2 = Sheet1.Range("F2").Value
    BA3 = Sheet1.Range("H2").Value
        
        ' Clearing old data to make room for new data
        
        If Not IsEmpty(Sheet1.Range("A2, C2, E2, G2")) Then
            
            ' Delete the oldest record (3 records back)
            Sheet1.Range("G2:H4").ClearContents
        
            ' Copy 2 Records back to 3 Records Back
            Sheet1.Range("E2:F4").Copy Sheet1.Range("G2")
        
            ' Copy Previous Record to 2 Records Back
            Sheet1.Range("C2:D4").Copy Sheet1.Range("E2")
            
            ' Copy Current to Previous Record
            Sheet1.Range("A2:B4").Copy Sheet1.Range("C2")
            
            ' Add New Data
            Sheet1.Range("L2:M4").Copy Sheet1.Range("A2")
            
        End If

With Sheet1
    If NewBA > BA3 And NewBA > BA2 And NewBA < PBA Then
        .Range("A2:B4").Copy Destination:=.Range("Q2")
        .Range("C2:D2").Copy Destination:=.Range("A2")
        .Range("Q2:R4").Copy Destination:=.Range("C2")
    ElseIf NewBA > BA4 And NewBA > BA3 And NewBA <= BA2 And NewBA <= PBA Then
        .Range("L2:M4").Copy Destination:=.Range("E2")
    ElseIf NewBA > BA4 And NewBA <= BA3 And NewBA <= BA2 And NewBA <= PBA Then
        .Range("L2:M4").Copy Destination:=.Range("G2")
    End If
End With

End Sub

TestingChrono.xlsm
ABCDEFGHIJKLM
1CurrentPrevious record2 Records Back3 Records Back
22/26/20223/1/20222/15/20222/25/20221/30/20222/14/20221/23/20221/29/20225/15/20222/27/2022
3Col1Col1Col2Col2Col3Col3Col4Col4NEW DATANEW DATA
4Col1Col1Col2Col2Col3Col3Col4Col4NEW DATANEW DATA
5
6FALSE
7
Sheet1
Cell Formulas
RangeFormula
B6B6=IF(AND(B2>H2,B2>F2,B2<D2),TRUE,FALSE)
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
without checking, it think you have to move the data first and then read your dates into variables.
so move the 1st 4 lines after the 1st if ... end if
 
Upvote 0
or (reverse sorting with small instead of large)
VBA Code: 
Sub ImportChrono()
     With sheet1
          .Range("A2:F4").Copy sheet1.Range("C2")
          .Range("L2:M4").Copy sheet1.Range("A2")

          For i = 1 To 4                                        'loop through your dates
               a = Array(.Range("B2").Value2 + 1 / 10000, .Range("D2").Value2 + 2 / 10000, .Range("F2").Value2 + 3 / 10000, .Range("H2").Value2 + 4 / 10000)     'array with your actual 4 dates (now double), add small value in case of duplicate values
               i1 = Application.Match(Application.Large(a, i), a, 0)     'position of the i-largest value in that array
               If i <> i1 Then                                  'wrong position
                    Set c1 = .Range("A2:B4").Offset(, (i - 1) * 2)     'actual data at that position
                    Set c2 = .Range("A2:B4").Offset(, (i1 - 1) * 2)     'wanted data at that position
                    Set c3 = .Range("Q2:R4")                    'auxiliary
                    c1.Copy c3                                  'copy actual to aux
                    c2.Copy c1                                  'copy wanted to actual
                    c3.Copy c2                                  'copy aux to wanted
               End If
          Next
     End With

End Sub
 
Upvote 0
BSALV said:
without checking, it think you have to move the data first and then read your dates into variables.
so move the 1st 4 lines after the 1st if ... end if
Click to expand...
Sorry I should have been more clear, the issue I was mentioned is in this code specifically.

VBA Code: 
With Sheet1
    If NewBA > BA3 And NewBA > BA2 And NewBA < PBA Then
        .Range("A2:B4").Copy Destination:=.Range("Q2")
        .Range("C2:D2").Copy Destination:=.Range("A2")
        .Range("Q2:R4").Copy Destination:=.Range("C2")
    ElseIf NewBA > BA4 And NewBA > BA3 And NewBA <= BA2 And NewBA <= PBA Then
        .Range("L2:M4").Copy Destination:=.Range("E2")
    ElseIf NewBA > BA4 And NewBA <= BA3 And NewBA <= BA2 And NewBA <= PBA Then
        .Range("L2:M4").Copy Destination:=.Range("G2")
    End If
End With
 
Upvote 0
BSALV said:
or (reverse sorting with small instead of large)
VBA Code: 
Sub ImportChrono()
     With sheet1
          .Range("A2:F4").Copy sheet1.Range("C2")
          .Range("L2:M4").Copy sheet1.Range("A2")

          For i = 1 To 4                                        'loop through your dates
               a = Array(.Range("B2").Value2 + 1 / 10000, .Range("D2").Value2 + 2 / 10000, .Range("F2").Value2 + 3 / 10000, .Range("H2").Value2 + 4 / 10000)     'array with your actual 4 dates (now double), add small value in case of duplicate values
               i1 = Application.Match(Application.Large(a, i), a, 0)     'position of the i-largest value in that array
               If i <> i1 Then                                  'wrong position
                    Set c1 = .Range("A2:B4").Offset(, (i - 1) * 2)     'actual data at that position
                    Set c2 = .Range("A2:B4").Offset(, (i1 - 1) * 2)     'wanted data at that position
                    Set c3 = .Range("Q2:R4")                    'auxiliary
                    c1.Copy c3                                  'copy actual to aux
                    c2.Copy c1                                  'copy wanted to actual
                    c3.Copy c2                                  'copy aux to wanted
               End If
          Next
     End With

End Sub
Click to expand...
This works for the basic setup but the final build is going to require moving 3 sets of data to the correct location.

I tried to expand on it but by time I get down to c1.Copy c3 I get an error "Action won't work with multiple selections", how would I work around that issue?

VBA Code: 
Sub ImportChrono()
     With Sheet1
          .Range("G2:H4").ClearContents
          .Range("E2:F4").Copy Sheet1.Range("G2")
          .Range("C2:D4").Copy Sheet1.Range("E2")
          .Range("A2:F4").Copy Sheet1.Range("C2")
          .Range("L2:M4").Copy Sheet1.Range("A2")
          .Range("L15:M16").Copy Sheet1.Range("A15")

          For i = 1 To 4                                        'loop through your dates
               a = Array(.Range("B2").Value2 + 1 / 10000, .Range("D2").Value2 + 2 / 10000, .Range("F2").Value2 + 3 / 10000, .Range("H2").Value2 + 4 / 10000)
               'array with your actual 4 dates (now double), add small value in case of duplicate values
               i1 = Application.Match(Application.Large(a, i), a, 0)     'position of the i-largest value in that array
               If i <> i1 Then                                  'wrong position
                    Set c1 = .Range("A2:B4, A15:B16").Offset(, (i - 1) * 2)     'actual data at that position
                    Set c2 = .Range("A2:B4, A15:B16").Offset(, (i1 - 1) * 2)     'wanted data at that position
                    Set c3 = .Range("Q2:R4, Q15:R16")                    'auxiliary
                    c1.Copy c3                                  'copy actual to aux
                    c2.Copy c1                                  'copy wanted to actual
                    c3.Copy c2                                  'copy aux to wanted
               End If
          Next
     End With

End Sub
 
Upvote 0
Sub ImportChrono()
With sheet1
.Range("A2:H4").Copy sheet1.Range("C2")
.Range("L2:M4").Copy sheet1.Range("A2")

For i = 1 To 5 'loop through your dates
a = Array(.Range("B2").Value2 + 1 / 10000, .Range("D2").Value2 + 2 / 10000, .Range("F2").Value2 + 3 / 10000, .Range("H2").Value2 + 4 / 10000, .Range("j2").Value2 + 5 / 10000) 'array with your actual 4 dates (now double), add small value in case of duplicate values
i1 = Application.Match(Application.Large(a, i), a, 0) 'position of the i-largest value in that array
If i <> i1 Then 'wrong position
Set c1 = .Range("A2:B4").Offset(, (i - 1) * 2) 'actual data at that position
Set c2 = .Range("A2:B4").Offset(, (i1 - 1) * 2) 'wanted data at that position
Set c3 = .Range("Q2:R4") 'auxiliary
c1.Copy c3 'copy actual to aux
c2.Copy c1 'copy wanted to actual
c3.Copy c2 'copy aux to wanted
End If
Next
End With

End Sub
 
Upvote 0
sorry, in previous post, i hadn't seen those rows 15:16
VBA Code: 
Sub ImportChrono()

     With Sheets("sheet1")
          .Range("A2:H4").Copy .Range("C2")                     '1st block of 3 rows
          .Range("L2:M4").Copy .Range("A2")

          .Range("A15:H16").Copy .Range("C15")                  '2nd block of 2 rows
          .Range("L15:M16").Copy .Range("A15")

          offset_Q = Columns("Q").Column - .Columns("A").Column     'Column Q is your aux. column = x columns to the right
          For i = 1 To 5                                        'loop through your dates
               a = Array(.Range("B2").Value2 + 1 / 10000, .Range("D2").Value2 + 2 / 10000, .Range("F2").Value2 + 3 / 10000, .Range("H2").Value2 + 4 / 10000, .Range("j2").Value2 + 5 / 10000)     'array with your actual 4 dates (now double), add small value in case of duplicate values
               i1 = Application.Match(Application.Large(a, i), a, 0)     'position of the i-largest value in that array
               If i <> i1 Then                                  'wrong position
                    For j = 0 To 1                              '2 loops, once for
                         If j = 0 Then Set c0 = .Range("A2:B4") Else Set c0 = .Range("A15:B16")     '1st or 2nd block
                         Set c1 = c0.Offset(, (i - 1) * 2)      'actual data at that position
                         Set c2 = c0.Offset(, (i1 - 1) * 2)     'wanted data at that position
                         Set c3 = c0.Offset(, offset_Q)         'auxiliary
                         c1.Copy c3                             'copy actual to aux
                         c2.Copy c1                             'copy wanted to actual
                         c3.Copy c2                             'copy aux to wanted
                    Next
               End If
          Next
     End With

End Sub
 
Upvote 0
BSALV said:
sorry, in previous post, i hadn't seen those rows 15:16
VBA Code: 
Sub ImportChrono()

     With Sheets("sheet1")
          .Range("A2:H4").Copy .Range("C2")                     '1st block of 3 rows
          .Range("L2:M4").Copy .Range("A2")

          .Range("A15:H16").Copy .Range("C15")                  '2nd block of 2 rows
          .Range("L15:M16").Copy .Range("A15")

          offset_Q = Columns("Q").Column - .Columns("A").Column     'Column Q is your aux. column = x columns to the right
          For i = 1 To 5                                        'loop through your dates
               a = Array(.Range("B2").Value2 + 1 / 10000, .Range("D2").Value2 + 2 / 10000, .Range("F2").Value2 + 3 / 10000, .Range("H2").Value2 + 4 / 10000, .Range("j2").Value2 + 5 / 10000)     'array with your actual 4 dates (now double), add small value in case of duplicate values
               i1 = Application.Match(Application.Large(a, i), a, 0)     'position of the i-largest value in that array
               If i <> i1 Then                                  'wrong position
                    For j = 0 To 1                              '2 loops, once for
                         If j = 0 Then Set c0 = .Range("A2:B4") Else Set c0 = .Range("A15:B16")     '1st or 2nd block
                         Set c1 = c0.Offset(, (i - 1) * 2)      'actual data at that position
                         Set c2 = c0.Offset(, (i1 - 1) * 2)     'wanted data at that position
                         Set c3 = c0.Offset(, offset_Q)         'auxiliary
                         c1.Copy c3                             'copy actual to aux
                         c2.Copy c1                             'copy wanted to actual
                         c3.Copy c2                             'copy aux to wanted
                    Next
               End If
          Next
     End With

End Sub
Click to expand...
Thanks for this, I'm in over my head on this one. lol. I'll have to spend some time watching it run so I can have a better understanding of what's going on and how I can adopt something like this for my final build.
 
Upvote 0
So I updated it with more data and notes to give a better idea of what I'm trying to do.

The user is going to import 3 sets of data (at one time) and it goes into 3 separate areas on the sheet depending on the date at the top and placement of the first set. Currently I'm only attempting to get it done with 2 locations.

This clears the data, moves it and does the placement of the first data set without issue.

The data set from A16 on however doesn't work and I'm not experienced enough with this code to know where to go from here. If you could give me some direction on how to expand. I don't want to keep bothering you, lol.

As you can probably tell, you can ignore the template for reset data that was just to make it easier to make changes and re-run the code.

VBA Code: 
Sub ImportChrono()
    With Sheets("sheet1")
          .Range("G2:H14, A43:F50").ClearContents ' Clear oldest data set
          .Range("E2:F14").Copy Sheet1.Range("G2") ' Move 3rd data set to 4th
          .Range("A34:F41").Copy Sheet1.Range("A43")
         
          .Range("C2:D14").Copy Sheet1.Range("E2") ' Move 2nd data set to 3rd
          .Range("A25:F32").Copy Sheet1.Range("A34")
         
          .Range("A2:F14").Copy Sheet1.Range("C2") ' Move 1st data set to 2nd
          .Range("A16:F23").Copy Sheet1.Range("A25")
         
          .Range("L2:M14").Copy Sheet1.Range("A2") ' Imported data from user goes inot first dataset
          .Range("O3:T10").Copy Sheet1.Range("A16") ' but needs below function to determine actual placement based on end date

          offset_Q = Columns("V").Column - .Columns("A").Column     'Column V is your aux. column = x columns to the right
          For i = 1 To 5                                        'loop through your dates
               a = Array(.Range("B2").Value2 + 1 / 10000, .Range("D2").Value2 + 2 / 10000, .Range("F2").Value2 + 3 / 10000, .Range("H2").Value2 + 4 / 10000, .Range("j2").Value2 + 5 / 10000)     'array with your actual 4 dates (now double), add small value in case of duplicate values
               i1 = Application.Match(Application.Large(a, i), a, 0)     'position of the i-largest value in that array
               If i <> i1 Then                                  'wrong position
                    For j = 0 To 1                              '2 loops, once for
                         If j = 0 Then Set c0 = .Range("A2:B14") Else Set c0 = .Range("A16:F23")     '1st or 2nd block
                         Set c1 = c0.Offset(, (i - 1) * 2)      'actual data at that position
                         Set c2 = c0.Offset(, (i1 - 1) * 2)     'wanted data at that position
                         Set c3 = c0.Offset(, offset_Q)         'auxiliary
                         c1.Copy c3                             'copy actual to aux
                         c2.Copy c1                             'copy wanted to actual
                         c3.Copy c2                             'copy aux to wanted
                    Next
               End If
          Next
     End With
End Sub

TestingChrono.xlsm
ABCDEFGHIJKLMNOPQRSTUVW
11st Data Set2nd Data Set3rd Data set4th Data setNew data being imported by user
22/26/20223/1/20222/15/20222/25/20221/30/20222/14/20221/23/20221/29/20225/15/20222/27/2022
3Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEWNEWNEWNEWNEWNEWNEW
4Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEWNEWNEWNEWNEWNEWNEW
5Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEWNEWNEWNEWNEWNEWNEW
6Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEWNEWNEWNEWNEWNEWNEW
7Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEWNEWNEWNEWNEWNEWNEW
8Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEWNEWNEWNEWNEWNEWNEW
9Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEWNEWNEWNEWNEWNEWNEW
10Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEWNEWNEWNEWNEWNEWNEW
11Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEW
12Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEW
13Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEW
14Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4NEWNEW
15
16Data 1Data 1Data 1Data 1Data 1Data 1
17Data 1Data 1Data 1Data 1Data 1Data 1
18Data 1Data 1Data 1Data 1Data 1Data 1Template for reset
19Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Template for reset
20Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1########3/1/2022################################################
21Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
22Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
23Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
24Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
25Data 2Data 2Data 2Data 2Data 2Data 2Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
26Data 2Data 2Data 2Data 2Data 2Data 2Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
27Data 2Data 2Data 2Data 2Data 2Data 2Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
28Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
29Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
30Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
31Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
32Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 2Data 1Data 1Data 2Data 2Data 3Data 3Data 4Data 4
33Data 2Data 2Data 2Data 2Data 2Data 2
34Data 3Data 3Data 3Data 3Data 3Data 3Data 2Data 2Data 2Data 2Data 2Data 2
35Data 3Data 3Data 3Data 3Data 3Data 3Data 2Data 2Data 2Data 2Data 2Data 2
36Data 3Data 3Data 3Data 3Data 3Data 3
37Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3
38Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3
39Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3
40Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3
41Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3Data 3
42Data 3Data 3Data 3Data 3Data 3Data 3
43Data 4Data 4Data 4Data 4Data 4Data 4Data 3Data 3Data 3Data 3Data 3Data 3
44Data 4Data 4Data 4Data 4Data 4Data 4Data 3Data 3Data 3Data 3Data 3Data 3
45Data 4Data 4Data 4Data 4Data 4Data 4
46Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4
47Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4
48Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4
49Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4
50Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4Data 4
51Data 4Data 4Data 4Data 4Data 4Data 4
52Data 4Data 4Data 4Data 4Data 4Data 4
53Data 4Data 4Data 4Data 4Data 4Data 4
54
55
Sheet1
 
Upvote 0
2 macros, the 1st is to fill a sheet with data and only while testing in an empty sheet
the 2nd is for real.
Later you can eliminate all those msgboxes and application.goto's , they are there for demonstration

VBA Code: 
Sub NewStart_Reset()
     '*********************************************
     'this macro is just for making a new fresh start, while testing
     '*********************************************
     With Sheets("sheet1")
          .UsedRange.Clear
          .Cells.HorizontalAlignment = xlCenter

          Set Block1 = .Range("A16:F23")                        'a block of data
          For i = 0 To 3
               Block1.Offset(i * (Block1.Rows.Count + 1)).Value = "data" & i + 1
          Next
          .Range("O3:T10").Value = "data0"

          Set Block2 = .Range("A2:B14")                         'range of your 1st data set in the rows 2:14
          For i = 0 To 2
               Block2.Offset(, i * 2).Value = "data" & i + 1
          Next
          .Range("L2:M14").Value = "data0"                      ' Imported data from user goes inot first dataset
          With Range("A2:m2")
               .Value = [transpose(44555+row(A1:A100)*7)]       'fill 2nd row with dates
               .NumberFormat = "mm/dd/YY"                       'apply dateformat on that row
          End With

     End With
End Sub

Sub ImportChrono()
     With Sheets("sheet1")

     '************************************************************
     'you have 4 blocks of 8*6, copy 3 blocks 1  block down and copy a new one on top
     '*************************************************************
          Set Block1 = .Range("A16:F23")                        'a block of data
          For i = 2 To 0 Step -1                                'you have 4 sets of those data, move them by 1, vertical
               Application.Goto Block1.Offset(i * (Block1.Rows.Count + 1)), 1
               MsgBox "copy : " & Block1.Offset(i * (Block1.Rows.Count + 1)).Address & vbLf & " to : " & Block1.Offset((i + 1) * (Block1.Rows.Count + 1)).Address
               Block1.Offset(i * (Block1.Rows.Count + 1)).Copy Block1.Offset((i + 1) * (Block1.Rows.Count + 1))
          Next
          MsgBox "copy : " & .Range("O3:T10").Address & vbLf & " to : " & .Range("A16").Address
          .Range("O3:T10").Copy .Range("A16")                   ' move a new block in the first

     '***************************************************************************************
     'you have 4 blocks of 13*2 (but is 1 contigious block), copy 3 blocks 1  block to the right and copy a new one on LHS
     '***************************************************************************************
          Application.Goto .Range("A1")
          Set Block2 = .Range("A2:B14")                         'range of your 1st data set in the rows 2:14
          MsgBox "copy : " & Block2.Resize(, 6).Address & vbLf & " to : " & Block2.Offset(, 2).Address
          Application.DisplayAlerts = False                     'disable warnings
          Block2.Resize(, 6).Copy Block2.Offset(, 2)            'copy 3 of those sets, 1 set(=2 columns) to the right
          Application.DisplayAlerts = True
          MsgBox "copy : " & .Range("L2:M14").Address & vbLf & " to : " & .Range("A2").Address
          .Range("L2:M14").Copy .Range("A2")                    ' Imported data from user goes inot first dataset

     '*****************************************************
     'now check that those 4 relevant cells are sorted in a descending order
     '*****************************************************
          offset_Q = Columns("V").Column - .Columns("A").Column     'Column V is your aux. column = x columns to the right
          For i = 1 To 4                                        'loop through your dates
     'make sure that those cells have valid date-values !!!!!
               a = Array(.Range("B2").Value2 - 1 / 10000, .Range("D2").Value2 - 2 / 10000, .Range("F2").Value2 - 3 / 10000, .Range("H2").Value2 - 4 / 10000)     'array with your actual 4 dates (now double), add small value in case of duplicate values
               i1 = Application.Match(Application.Large(a, i), a, 0)     'position of the i-largest value in that array
               If i <> i1 Then                                  'wrong position
                    Set c0 = .Range("A2:B14")                   '1st block
                    Set c1 = c0.Offset(, (i - 1) * 2)           'actual data at that position
                    Set c2 = c0.Offset(, (i1 - 1) * 2)          'wanted data at that position
                    Set c3 = c0.Offset(, offset_Q)              'auxiliary
                    MsgBox Format(c1.Cells(1, 2), "mm/dd/yy") & "   " & Format(c2.Cells(1, 2), "mm/dd/yy") & vbLf & "swap " & c1.Address & " with " & c2.Address
                    c1.Copy c3                                  'copy actual to aux
                    c2.Copy c1                                  'copy wanted to actual
                    c3.Copy c2                                  'copy aux to wanted
               End If
          Next
     End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
VBA remove leading zeros
2
Replies
14
Views
1K
Joe4
Joe4
P
  • Question
Help with Vba Code
Replies
3
Views
176
Coyotex3
C
G
  • Question
VBA - add formula to cell when created
Replies
2
Views
302
Golaidron
G
L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
350
RoryA
RoryA
K
  • Question
Copying data from one table into another worksheet
Replies
2
Views
430
Herakles
H

Forum statistics

Threads
1,215,375
Messages
6,124,578
Members
449,174
Latest member
chandan4057

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