Transpose & reorg data from 2 WS to new WB

[u473]

Transpose & reorg data from sheets "Force" and "Hours" to new workbook
sheet1
I need to adapt this skeleton code
....
Enter data Source WB path
Enter data Source WB Name
Enter data Destin. WB path
Enter data Destin. WB Name
' Same data map, in rows & cols, for "Force" & "Hours sheets
DateRange = A1: to Last Col.
Actvity Range = A1: to Last Row
DataRange = A1 : to Last Row - Last Col.
For C = 2 to MaxCol(DateRange)
For R = 2 to Max(DataRange)
' Write new WB Sheet1
Date = Date(Col(C), Row(1))
Activity = Value(Col(C1),Row(R))
' From "Force" sheet
Force = Value(Col(C),Row(R))
' From "Hours" sheet
Hours = Value(Col(C),Row(R))
Next
Next
.....
Data Source : Sheet1 "Force"
A B C D E
1. Activity Oct1 Oct2 Oct 3 Oct4
2. X 4 13 1
3. Y 6 7 9
......
Data Source : Sheet1 "Hours"
A B C D E
1. Activity Oct1 Oct2 Oct 3 Oct4
2. X 32 104 10
3. Y 72 56 72
.......
Expected result : New Workbook "Alpha" Sheet1
A B C D
1. Date Activity Force Hours
2. Oct1 X 4 32
3. Oct2 X 13 104
4. Oct4 X 1 10
5. Oct2 Y 6 72
6. Oct3 Y 7 56
7. Oct4 Y 79 72
......
Help appreciated,
J.P.

 

[Per Jessen]

Hi

As I understand it you want to create new workbook, where the data is
transposed to:

Sub ReorgData()
Dim SourceWBa As Workbook
Dim SourceSHa As Worksheet
Dim SourceWBb As Workbook
Dim SourceSHb As Worksheet
Dim DestCell As Range
Dim DestWB As Workbook
Dim DestSh As Worksheet
Dim FileToOpen As Variant
Dim LastCol As Long
Dim LastRow As Long
Dim MyPath As String

Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename _
(filefilter:="Excel Files (*.xls),*.xls", Title:="Open Force
workbook")
If FileToOpen = False Then Exit Sub 'No workbook selected
Set SourceWBa = Workbooks.Open(FileToOpen)
FileToOpen = Application.GetOpenFilename _
(filefilter:="Excel Files (*.xls),*.xls", Title:="Open Hours
workbook")
If FileToOpen = False Then Exit Sub 'No workbook selected
Set SourceWBb = Workbooks.Open(FileToOpen)

Set DestWB = Workbooks.Add
Set SourceSHa = SourceWBa.Worksheets("Sheet1")
Set SourceSHb = SourceWBb.Worksheets("Sheet1")
Set DestSh = DestWB.Worksheets("Sheet1")
Set DestCell = DestSh.Range("A1")
LastRow = SourceSHa.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = SourceSHa.Cells(1, Columns.Count).End(xlToLeft).Column
MyPath = SourceWBa.Path
ChDir MyPath 'By default save to source path
SaveFileName = Application.GetSaveAsFilename(InitialFilename:="Alpha",
_
filefilter:="Excel Files (*.xls), *.xls", Title:="Enter Alpha
workbook name")

DestCell = "Date"
DestCell.Offset(0, 1) = "Activity"
DestCell.Offset(0, 2) = "Force"
DestCell.Offset(0, 3) = "Hours"
Set DestCell = DestCell.Offset(1, 0)
For c = 2 To LastCol
For r = 2 To LastRow
' Write new WB Sheet1
If SourceSHa.Cells(r, c) <> "" Then
DestCell = SourceSHa.Cells(1, c)
DestCell.Offset(0, 1) = SourceSHa.Cells(r, 1)
' From "Force" sheet
DestCell.Offset(0, 2) = SourceSHa.Cells(r, c)
' From "Hours" sheet
DestCell.Offset(0, 3) = SourceSHb.Cells(r, c)
Set DestCell = DestCell.Offset(1, 0)
End If
Next
Next
DestSh.Range("A1").CurrentRegion.Sort Key1:=Range("B2"),
Order1:=xlAscending, _
Key2:=Range("A2"), Order2:=xlAscending, Header:=xlYes,
OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
SourceWBa.Close
SourceWBb.Close
DestWB.SaveAs Filename:=SaveFileName
Application.ScreenUpdating = True
End Sub


Regards,
Per

 

[u473]

Thank you Per,
You made my day.
I will test it.