Copy and Loop Data

Posted on 2011-10-26
Last Modified: 2012-05-12
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.

Question by:Cartillo
    LVL 19

    Assisted Solution

    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

    LVL 17

    Accepted Solution

    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")
        ' 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)
        ' 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
                    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)
        ' 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

    LVL 19

    Expert Comment

    @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?

    LVL 17

    Expert Comment

    @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.

    Author Closing Comment


    Thanks a lot for the superb solution.

    Featured Post

    How to improve team productivity

    Quip adds documents, spreadsheets, and tasklists to your Slack experience
    - Elevate ideas to Quip docs
    - Share Quip docs in Slack
    - Get notified of changes to your docs
    - Available on iOS/Android/Desktop/Web
    - Online/Offline

    Join & Write a Comment

    Sparklines have been introduced with Excel 2010 and are a useful tool for creating small in-cell charts, used for example in dashboards. Excel 2010 offers three different types of Sparklines: Line, Column and Win/Loss. What it does not offer is a…
    How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
    The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
    This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

    754 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    15 Experts available now in Live!

    Get 1:1 Help Now