Copy and Loop Data

Hi Experts,

I would like to request Experts help create a macro to copy data from “Data” (column A: D) sheet to “Detail” sheet (Column B :E). However, the date info needs to copied at column A (Detail) and loop the date. I have manually copied the data at Detail sheet for Experts to get a better view. Hope Expert will help me create this feature.



Data-Date.xls
CartilloAsked:
Who is Participating?
 
andrewssd3Commented:
The pivot table is a good solution, but does still suffer from the problem that the date is not repeated on every row, and some times for lookups etc, it's convenient to have that.  This code creates the Detail sheet as I think you want it, minus some of your formatting, which could easily be added.  Like any code of this sort it's dependent on the format of the input data, but this matches yours.  The main assumption is that all the detail rows for one day will be contiguous wiith no blank rows.  In the Detail sheet, I have copied the date as a 'proper' Excel date, with a number format to display it with the day in brackets after it. This should make filtering, etc easier.
Public Sub CopyData()

    Dim shtData As Excel.Worksheet
    Dim shtDetail As Excel.Worksheet
    Dim rngOut As Excel.Range
    Dim rngIn As Excel.Range
    Dim lngLastRow As Long
    Dim x As Long
    
    Dim dtCurrentDate As Date

    Dim aHeaders As Variant
    Const clngColToCopy As Long = 4

    aHeaders = Array("Date", "Time", "Status", "Title", "Total Duration")

    Set shtData = ActiveWorkbook.Worksheets("Data")
    Set shtDetail = ActiveWorkbook.Worksheets("Detail")

    shtDetail.UsedRange.Clear
    
    ' put the headers into the Detail sheet
    Set rngOut = shtDetail.Cells(1)
    rngOut.Resize(1, UBound(aHeaders) - LBound(aHeaders) + 1).Value = aHeaders

    ' point rngOut to the next row, and one column across to account for the date column
    Set rngOut = rngOut.Offset(1, 1)
    

    Set rngIn = shtData.UsedRange
    lngLastRow = rngIn.Rows(rngIn.Rows.Count).Row
    
    ' move to the start of the data
    Set rngIn = rngIn.Cells(1)
    Do While (rngIn.Value <> "Date/Time") And (rngIn.Row < lngLastRow)
        Set rngIn = rngIn.Offset(1, 0)
    Loop
    
    ' didn't find the expected header
    If (rngIn.Row >= lngLastRow) Then Exit Sub
    
    Do While (rngIn.Row <= lngLastRow)
        
        If Not IsEmpty(rngIn.Value) Then
            If InStr(1, rngIn.Value, "/") > 0 Then      ' a new day
                x = InStr(1, rngIn.Value, "(")
                If x > 0 Then
                    dtCurrentDate = CDate(Left$(rngIn.Value, x - 1))
                End If
            Else
                If IsNumeric(rngIn.Value) Then      ' a time row
                    ' get all the times - assumes there are no blank rows in a day
                    Set rngIn = shtData.Range(rngIn, rngIn.End(xlDown))
                    Set rngIn = rngIn.Resize(rngIn.Rows.Count, clngColToCopy)
                    
                    ' now copy them to the output area
                    Set rngOut = rngOut.Resize(rngIn.Rows.Count, rngIn.Columns.Count)
                    rngOut.Value = rngIn.Value
                    ' now put in the dates
                    rngOut.Offset(0, -1).Resize(rngOut.Rows.Count, 1).Value = dtCurrentDate
                    ' move rngOut on to the next row
                    Set rngOut = rngOut.Offset(rngOut.Rows.Count, 0).Resize(1, 1)
                    
                End If
            End If
        End If
        
        Set rngIn = rngIn.Offset(rngIn.Rows.Count, 0).Resize(1, 1)
    Loop
    
    ' apply some number formatting
    shtDetail.Columns(1).Cells.NumberFormat = "dd/mm/yyyy (ddd)"
    shtDetail.Columns(2).Cells.NumberFormat = "hh:mm"
    shtDetail.Columns(5).Cells.NumberFormat = "hh:mm"

End Sub

Open in new window

0
 
regmigrantCommented:
you dont need a macro for this if you are willing to accept some limitations on the output format a pivto table will be i
Reg

Data-Date-1--pivot.xlsx
0
 
regmigrantCommented:
@andrew - Kudos on the code, but doesnt the 'repeat all items' option sort out the repeating field on the pivot table? - or is that only available in later versions?

0
 
andrewssd3Commented:
@regmigrant - yes you're right - I didn't know that option but I've found it on Excel 2010 - not sure if it was available in 2003 and before.

Having said that I've just noticed the pivot table is based on the Detail sheet - which is what @cartillo wants us to create - so you need to run the code to get the details sheet before you can generate the pivot.
0
 
CartilloAuthor Commented:
Hi,

Thanks a lot for the superb solution.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.