Row dates into one column

Closed
alish - Jul 23, 2010 at 02:28 AM
rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
- Jul 24, 2010 at 05:16 AM
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

rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
769
Jul 24, 2010 at 05:16 AM
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
0