asked on

VBA: Reformat date/time cell and copy/paste to separate workbook based on tab name

I have 10 reports that I pull out of dynamics and need to reformat the date/time cell, add a week and month column based on the date in the date cell. All 10 reports have the same column structure but number of rows vary. After the columns are reformatted and two additional columns added, I need to copy and paste everything from row A2:Fend of data in another workbook (compiled scorecard data_Dev2.xlsm) on worksheet 6 (changes based on the report pulled from dynamics). Once I paste the data onto the "compiled scorecard" report I do not have to go back to the sample report. I will attach a copy of a sample report that comes out of dynamics (sample report.xlsm), a sample of how the data should look after reformatted (sample report after reformatted.xlsm) and the workbook it needs to be pasted on (compiled scorecard data_Dev2.xlsm). I have completed these steps using the macro recorder however I am now running into a "out of memory" issue and unable to run these macros. If you could give me an idea of how to properly structure this VBA as to avoid running into the "out of memory" issue.
sample-report-after-reformatted.xlsm
sample-report.xlsm
compiled-scorecard-data_Dev2.xlsm

Joe Howard

What data in supposed to be in the "week" column?

Here is a macro that will format your data as requested, (as of now the code will add the week number to the week column).

Sub Demo()
    Dim rng As Range, c As Range
    Set rng = Range("F2:F" & Range("F" & Rows.Count).End(xlUp).Row)
    Range("G1").Value = "Date"
    Range("H1").Value = "Time"
    Range("I1").Value = "Week"
    Range("J1").Value = "Month"
    For Each c In rng.Cells
        c.Offset(0, 1).Value = DateValue(c.Value)
        c.Offset(0, 2).Value = TimeValue(c.Value)
        c.Offset(0, 3).Value = WorksheetFunction.WeekNum(c.Value, vbSunday)
        c.Offset(0, 4).Value = Format(c.Value, "mmm")
    Next
End Sub

Open in new window

p.s.
Please attach the code you're having issues with.

Gustav Brock

This function will do that in a few seconds directly when run from the source workbook:

Public Function CopyTable()

    Dim Table       As Excel.ListObject
    Dim Record      As Excel.ListRow
    
    Dim Destination As Excel.Workbook
    Dim Target      As Excel.Worksheet
    Dim RowIndex    As Long
    Dim ColumnIndex As Long
    Dim RowDate     As Date
    
    Set Destination = Workbooks.Open("c:\test\compiled-scorecard-data_Dev2.xlsm")  ' adjust path.
    Set Target = Destination.Worksheets(6)
    
    ' Skip header row.
    RowIndex = 1
    
    Set Table = ThisWorkbook.Worksheets(1).ListObjects("Table1")
    For Each Record In Table.ListRows
        RowIndex = RowIndex + 1
        ColumnIndex = 1
        RowDate = Record.Range.Columns(6).Value
        Target.Cells(RowIndex, ColumnIndex).Value = Record.Range.Columns(4).Value
        ColumnIndex = 2
        Target.Cells(RowIndex, ColumnIndex).Value = Record.Range.Columns(5).Value
        ColumnIndex = 3
        Target.Cells(RowIndex, ColumnIndex).Value = DateValue(RowDate)
        ColumnIndex = 4
        Target.Cells(RowIndex, ColumnIndex).Value = TimeValue(RowDate)
        ColumnIndex = 5
        Target.Cells(RowIndex, ColumnIndex).Value = DateAdd("d", 1 - Weekday(RowDate, vbMonday), RowDate)
        ColumnIndex = 6
        Target.Cells(RowIndex, ColumnIndex).Value = MonthName(Month(RowDate))
    Next

End Function

Open in new window

See the attached demo, please.

Joe Howard

"no longer need this" hardly seems like a reason to delete a question.
You've asked a question, experts took time to respond, show some respect!

Michael Dobbins

ASKER

Joe - I had no idea people got "points" for responding to questions or that my deleting it would impact them negatively. It is showing as an open question and I simply wanted to close it so other people would not spend time trying to solve a problem that I no longer need solved.

This question needs an answer!

Become an EE member today

7 DAY FREE TRIAL

Members can start a 7-Day Free trial then enjoy unlimited access to the platform.

View membership options

Learn why we charge membership fees

We get it - no one likes a content blocker. Take one extra minute and find out why we block content.