Row dates into one columnClosed

Question

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.


Configuration: Windows XP / Internet Explorer 7.0

rizvisa1 · Answer

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

Row dates into one column

1 response

Similar discussions

Subscribe To Our Newsletter!