none
Structure Data using VBA RRS feed

  • Question

  • 

    Hi All,

    I have data in an excel spreadsheet however I want to structure it into blocks so that I can write it in the format below structured in Months. How can I archive this using VBA code?

    Data:

    Structure: 

    Spreadsheet


    Monday, June 25, 2018 12:21 PM

Answers

  • This code assumes that:

    1) the only entries in row 1 are dates, in columns B, F, etc.

    2) your headers are in rows 2 and 3

    3) data for each month is entered into rows starting in row 4 and without any blanks in between

    Run this on a copy of your worksheet:

    Sub TestMacro()
        Dim i As Long
        Dim c As Long
        Dim r As Long
        Dim n As Long
        
        Range("A:A").Insert
        r = 4
        
        For i = 1 To Application.CountA(Range("1:1"))
            c = (i - 1) * 4 + 3
            r = r + n
            n = Application.CountA(Columns(c)) - 3
            Range(Cells(r, 1), Cells(r + n - 1, 1)).Value = Cells(1, c).Value
            If c > 3 Then
                Range(Cells(4, c - 1), Cells(n + 3, c + 2)).Cut Cells(r, 2)
            End If
        Next i
        Columns(6).Resize(, ActiveSheet.UsedRange.Columns.Count).Delete
    End Sub

    Monday, June 25, 2018 6:50 PM
  • Hello khwezi Ngqongwa,

    Check if below code could work for you.

    Sub TestMacro()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim TempSheet As Worksheet
    Dim TargetSheet As Worksheet
    Worksheets("SourceSheet").Copy Worksheets(1)
    Set TempSheet = Worksheets(1)
    Set TargetSheet = ActiveWorkbook.Worksheets.Add
    Set TargetSheet = Worksheets(1)
    TempSheet.Name = "TempSheet"
    TargetSheet.Name = "TargetSheet"
    TempSheet.Sort.SortFields.Clear
    TempSheet.Sort.SortFields.Add Key:=TempSheet.Columns(1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
            xlSortNormal
     With TempSheet.Sort
            .SetRange TempSheet.UsedRange
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
     End With
        
     CurrentDate = ""
     lastRow = TempSheet.Cells(TempSheet.Rows.Count, 1).End(xlUp).Row
     For i = 1 To lastRow
       If Not TempSheet.Cells(i, 1) = CurrentDate Then
            CurrentDate = TempSheet.Cells(i, 1)
            TargetSheet.Columns("A:D").Insert Shift:=xlToRight
            TargetSheet.Cells(1, 2) = CurrentDate
            TargetSheet.Cells(2, 1) = "Total Length"
            TargetSheet.Cells(2, 2) = "Depth To Water"
            TargetSheet.Cells(2, 3) = "Standpipe Height"
            TargetSheet.Cells(2, 4) = "Comments Notes"
       End If
       lastTargetRow = TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Row
       TargetSheet.Cells(lastTargetRow + 1, 1) = TempSheet.Cells(i, 2)
       TargetSheet.Cells(lastTargetRow + 1, 2) = TempSheet.Cells(i, 3)
       TargetSheet.Cells(lastTargetRow + 1, 3) = TempSheet.Cells(i, 4)
       TargetSheet.Cells(lastTargetRow + 1, 4) = TempSheet.Cells(i, 5)
     Next i
     TargetSheet.Rows(2).WrapText = True
     TargetSheet.Rows(2).HorizontalAlignment = xlCenter
     TargetSheet.UsedRange.ColumnWidth = 9.5
     TempSheet.Delete
     
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
    
    End Sub

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    Tuesday, June 26, 2018 7:58 AM

All replies

  • This code assumes that:

    1) the only entries in row 1 are dates, in columns B, F, etc.

    2) your headers are in rows 2 and 3

    3) data for each month is entered into rows starting in row 4 and without any blanks in between

    Run this on a copy of your worksheet:

    Sub TestMacro()
        Dim i As Long
        Dim c As Long
        Dim r As Long
        Dim n As Long
        
        Range("A:A").Insert
        r = 4
        
        For i = 1 To Application.CountA(Range("1:1"))
            c = (i - 1) * 4 + 3
            r = r + n
            n = Application.CountA(Columns(c)) - 3
            Range(Cells(r, 1), Cells(r + n - 1, 1)).Value = Cells(1, c).Value
            If c > 3 Then
                Range(Cells(4, c - 1), Cells(n + 3, c + 2)).Cut Cells(r, 2)
            End If
        Next i
        Columns(6).Resize(, ActiveSheet.UsedRange.Columns.Count).Delete
    End Sub

    Monday, June 25, 2018 6:50 PM
  • Hello khwezi Ngqongwa,

    Check if below code could work for you.

    Sub TestMacro()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim TempSheet As Worksheet
    Dim TargetSheet As Worksheet
    Worksheets("SourceSheet").Copy Worksheets(1)
    Set TempSheet = Worksheets(1)
    Set TargetSheet = ActiveWorkbook.Worksheets.Add
    Set TargetSheet = Worksheets(1)
    TempSheet.Name = "TempSheet"
    TargetSheet.Name = "TargetSheet"
    TempSheet.Sort.SortFields.Clear
    TempSheet.Sort.SortFields.Add Key:=TempSheet.Columns(1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
            xlSortNormal
     With TempSheet.Sort
            .SetRange TempSheet.UsedRange
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
     End With
        
     CurrentDate = ""
     lastRow = TempSheet.Cells(TempSheet.Rows.Count, 1).End(xlUp).Row
     For i = 1 To lastRow
       If Not TempSheet.Cells(i, 1) = CurrentDate Then
            CurrentDate = TempSheet.Cells(i, 1)
            TargetSheet.Columns("A:D").Insert Shift:=xlToRight
            TargetSheet.Cells(1, 2) = CurrentDate
            TargetSheet.Cells(2, 1) = "Total Length"
            TargetSheet.Cells(2, 2) = "Depth To Water"
            TargetSheet.Cells(2, 3) = "Standpipe Height"
            TargetSheet.Cells(2, 4) = "Comments Notes"
       End If
       lastTargetRow = TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Row
       TargetSheet.Cells(lastTargetRow + 1, 1) = TempSheet.Cells(i, 2)
       TargetSheet.Cells(lastTargetRow + 1, 2) = TempSheet.Cells(i, 3)
       TargetSheet.Cells(lastTargetRow + 1, 3) = TempSheet.Cells(i, 4)
       TargetSheet.Cells(lastTargetRow + 1, 4) = TempSheet.Cells(i, 5)
     Next i
     TargetSheet.Rows(2).WrapText = True
     TargetSheet.Rows(2).HorizontalAlignment = xlCenter
     TargetSheet.UsedRange.ColumnWidth = 9.5
     TempSheet.Delete
     
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
    
    End Sub

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    Tuesday, June 26, 2018 7:58 AM