asked on

Copy Column Based on Date Criteria

Hi,

Need some help with some coding in Excel VBA which will do...

I have a Budget sheet, on the master sheet it currently has all the days covered for the next 10 years, i.e. some 3,650 columns which take forever to load!. Having reviewed what is actually happening only about 8 days a month actually show what is going out, so basically I need to be able to copy the entire column from Column D (which contains all the relevant forulas required) and place it in E, then F and so on as much is required to cover 10 years worth.

It needs to read in a range from =Summary!D8:D27 which contains the days actually used for any transfers to show, but must also include every FRIDAY regardless. And then change its Row 3 of its own column to reflect the actual date. The initial start date must come from D3 (Which would contain the day, month and year) to start with.

Then duplicate this method to to show ten years worth of columns and be dynamic so I could change my mind to say 20 yrs!.

Hope that makes sense.

Cheers

Arno Koster

could you post an example file with some data entries, this would greatly aid us...

StormFusion

ASKER

Attached an example, if you go to tab MASTER your see that Column D already contains contents that need to be duplicate E onwards, the day it shows must also be a workday, so bills that may go out on the 1st of the month generally will, unless the day is a holiday or SAT or SUN, in which case it needs to show the next available workday.

Cheers
Example.xlsm

Arno Koster

The column() formula works great when you want all days to be visible. You could opt to hide all unneccesary days/columns but they will still be present and take time to load.

There are two likely options :

- use the column formulae as they are now to populate the entire worksheet, copy and paste as values (thereby removing the need to recalculate the formula's over and over again) and removing all unneccesary columns. This can either be done by hand or using a macro.

- generate a list of all dates that you do want to have, and fill the master sheet columns with the chosen dates. This too can be done by hand or by making use of macro code.

If you choose which path you like best, i'll get you through...

StormFusion

ASKER

Hi,

Option 1 - This would start with a small file, but on open would generate the entire worksheet so on saving filesize would be greater, unless range is oblitered on save?

Option 2 - The list of required dates per month is in the Summary page, but this does not take into account working days or Fridays.

So maybe option 1 is best route? And kill the range on save.

StormFusion

ASKER

Arno Koster

That's worth a shot : you get a small file that can be opened quickly but will 'regenerate' the formulas for the days that you seem fit.

In order to minimize the time needed for the regenerating, step 2 would be a huge advantage. Incorporating working days and fridays is certainly possible because there are formulas for that.

can you try this :

Public Sub regenerate()
Dim dates As Dictionary
Dim date_list() As String
Dim date_day As String, date_month As Integer, date_year As Integer
Dim date_entry As String
Dim x, y
        
    Application.StatusBar = "initialising"
    Set dates = New Dictionary
    start_date = Worksheets("Master").Range("B3")
    
    Application.StatusBar = "adding all given dates"
    For date_year = Year(start_date) To (Year(start_date) + 9)
        For date_month = 1 To 12
            For pos = 1 To 17
                date_day = Worksheets("Summary").Range("D" & pos + 7)
                date_entry = date_day & "-" & date_month & "-" & date_year
                If IsDate(date_entry) Then
                    If Not dates.Exists(date_entry) Then
                        dates.Add date_entry, date_entry
                    End If
                End If
            Next pos
        Next date_month
    Next date_year
    
    Application.StatusBar = "adding all fridays"
    For x = start_date To start_date + 3649
        '-- monday = 1 so friday = 5
        If Weekday(x, vbMonday) = 5 Then
            If Not dates.Exists(x) Then dates.Add x, x
        End If
    Next x
    
    Application.StatusBar = "dictionary to array for easy sorting"
    ReDim date_list(dates.Count - 1)
    For x = 0 To dates.Count - 1
        date_list(x) = dates.Items(x)
    Next x
    
    Application.StatusBar = "sorting"
    xmax = UBound(date_list)
    For x = 0 To xmax
        For y = x + 1 To xmax
            If date_list(y) < date_list(x) Then
                '-- exchange items
                    temp = date_list(x)
                    date_list(x) = date_list(y)
                    date_list(y) = temp
            End If
        Next y
        Application.StatusBar = "sorting : " & CInt(1000 * x / xmax) / 10 & "%"
    Next x
    
    Application.StatusBar = "exporting dates to master sheet"
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    For x = 0 To dates.Count - 1
        Worksheets("Master").Cells(3, x + 5) = DateValue(dates.Items(x))
        '-- lookup last column name, strip $ signs
        lastcolumn = Mid(Worksheets("Master").Cells(3, x + 5).Address, 2)
        lastcolumn = Left(lastcolumn, InStr(lastcolumn, "$") - 1)
    Next x
    
    Application.StatusBar = "extending formulas"
    Set src = Worksheets("Master").Range("D5:D27")
    Set dst = Worksheets("Master").Range("D5:" & lastcolumn & "27")
    src.AutoFill Destination:=dst, Type:=xlFillDefault
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    Application.StatusBar = "cleaning up"
    Set src = Nothing
    Set dst = Nothing
    Set dates = Nothing
    
    Application.StatusBar = False

End Sub

Open in new window

StormFusion

ASKER

Hi akoster

Thank you for taking the time with that code, but it seems to stop at the first line Dim dates As Dictionary saying User-defined type not defined.

Im using Excel 2010 btw.

Cheers

Wayne

ASKER CERTIFIED SOLUTION

Arno Koster

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Ingeborg Hawighorst (Microsoft MVP / EE MVE)

This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.