Row dates into one column

[Closed]
Report
-
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
-
Hello,
I have a range of data (see below) and want to have all the date data (in columns through E) into one "Date" column (in column B)and and "Hours" column in column C. That way I have four entries for one empoyee (see table2 below)

table1
A B C D E
1 Empl# 2/12/10 2/19/10 2/26/10 3/5/10
2 1001 35 40 40 40
3 1002 40 40 40 40
4 1003 40 35 40 40
5 1004 35 40 40 40

table2
A B C
1 Empl# Date Hours
2 1001 2/12/10 35
3 1001 2/19/10 40
4 1001 2/26/10 40
5 1001 3/5/10 40
6 1002 2/12/10 40
7 1002 2/19/10 40
8 1002 2/26/10 40
9 1002 3/5/10 40
10 1003 2/12/10 40
11 1003 2/19/10 35
12 1003 2/26/10 40
13 1003 3/5/10 40

Please help. Thanks in advance.


1 reply

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
try this
Sub MoveRowsBlockToColumns2()
Dim sProcessSheet As String
Dim lStartAtRow As Long
Dim iColumnsBlockSize
Dim iPivotColumn As Integer

Dim lMaxRows As Long
Dim lThisRow As Long
Dim iMaxCol As Integer '

Dim sActiveSheet As String '
Dim bScreenUpdating As Boolean '


    sProcessSheet = "Sheet9"
    iColumnsBlockSize = 1
    lStartAtRow = 2
    iPivotColumn = 2
    
    bScreenUpdating = Application.ScreenUpdating
    sActiveSheet = ActiveSheet.Name
    
    On Error GoTo ERROR_HANDLER
    
    Sheets(sProcessSheet).Select
    Columns(2).Insert
    lMaxRows = Cells.Find("*", Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    lThisRow = lStartAtRow 'start from this row
    
    Do While lThisRow <= lMaxRows
        
        iMaxCol = Cells(lThisRow, Columns.Count).End(xlToLeft).Column
        
        If (iMaxCol > iColumnsBlockSize + iPivotColumn) Then
            Rows(lThisRow + 1 & ":" & lThisRow + iMaxCol - iPivotColumn - iColumnsBlockSize).Insert
            
            Range(Cells(lThisRow, iColumnsBlockSize + iPivotColumn + 1), Cells(lThisRow, iMaxCol)).Copy
            Cells(lThisRow + 1, iPivotColumn + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            Range(Cells(lThisRow, iColumnsBlockSize + iPivotColumn + 1), Cells(lThisRow, iMaxCol)).Clear
            
            Range(Cells(1, iColumnsBlockSize + iPivotColumn + 1), Cells(1, iMaxCol)).Copy
            Cells(lThisRow + 1, iPivotColumn).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            
            Cells(lThisRow, 1).Copy
            Range(Cells(lThisRow + 1, 1), Cells(lThisRow + iMaxCol - iPivotColumn - iColumnsBlockSize, 1)).PasteSpecial
    
            
        End If
        
        Cells(1, iColumnsBlockSize + iPivotColumn).Copy
        Cells(lThisRow, iPivotColumn).PasteSpecial
        
         If (iMaxCol > iColumnsBlockSize + iPivotColumn) Then
            lThisRow = lThisRow + iMaxCol - iPivotColumn - iColumnsBlockSize
            lMaxRows = lMaxRows + iMaxCol - iPivotColumn - iColumnsBlockSize
         
        End If
        
        lThisRow = lThisRow + 1
    Loop
    
    Range(Cells(1, iColumnsBlockSize + iPivotColumn), Cells(1, iMaxCol)).ClearContents
    Cells(1, 2) = "Date"
    Cells(1, 3) = "Hours"
    
End_Sub:

    Sheets(sActiveSheet).Select
    Application.ScreenUpdating = bScreenUpdating
    
    Exit Sub
    
ERROR_HANDLER:
    MsgBox Err.Description
    GoTo End_Sub

End Sub