Hi Anil,
I have started looking at your query. I'm getting somewhere with the code
below but if someone in this forum can me figure out why these lines are
not getting all values:
'This loop stores the number of times an activity occurs between 2 merged
cells --> need assistance,,, not accurate
ReDim actNb(0)
i = 0: j = 0
For Each c In r
If Not c.MergeCells Then
j = j + 1
Else
actNb(i) = j
i = i + 1
ReDim Preserve actNb(i)
j = 0
End If
Next
The code I have worked out is below. If someone can help, it would speed
things up otherwise I'll take another look this week-end if I can.
Sub ModuleA()
'wor is original data wou is output sheet
Dim wor As Worksheet, wou As Worksheet
Set wor = ThisWorkbook.Worksheets("Original")
Set wou = ThisWorkbook.Worksheets("Output")
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
End With
Dim r As Range
Dim c As Range
'hdr is an array to copy the first header
'emp is an array to store employee names
'act is an array to store the data related to the merged cells you label as
activity
'actNb is an array that should store the number of times of an activity for
each "firm"
Dim hdr(), emp(), firm(), act(), actNb()
Dim lastr As Long, lastc As Long
Dim empNb As Long
Dim i As Long, j As Long, k As Long
'formatting stuff...
wou.Cells.Delete
hdr = Array("Firm", "Activity", "Subtask", "No", "Capacity", "Modified Risk
Rating", "Name", "Hours", "EOM")
wou.Range("A1:i1") = hdr
wou.Range("A1:i1").Font.Bold = True
wou.Range("A1:I1").Interior.Color = 65535
lastc = wor.Cells(4, Columns.Count).End(xlToLeft).Column
emp = wor.Range(wor.Cells(4, 6), wor.Cells(4, lastc))
empNb = UBound(emp, 2)
ReDim act(0)
ReDim firm(0)
lastr = wor.Cells(Rows.Count, 1).End(xlUp).Row
'r stores the first column
Set r = wor.Range(wor.Cells(10, 1), wor.Cells(lastr, 1))
'this loop stores data in 2 arrays: act for merged cells values and firm
for Firm cell values
i = 0: j = 0
For Each c In r
If c.MergeCells Then
act(i) = c.Value
i = i + 1
ReDim Preserve act(i)
Else
firm(j) = c.Value
j = j + 1
ReDim Preserve firm(j)
End If
Next
i = i - 1
ReDim Preserve act(i)
j = j - 1
ReDim Preserve firm(j)
'This loop stores the number of times an activity occurs between 2 merged
cells --> need assistance,,, not accurate
ReDim actNb(0)
i = 0: j = 0
For Each c In r
If Not c.MergeCells Then
j = j + 1
Else
actNb(i) = j
i = i + 1
ReDim Preserve actNb(i)
j = 0
End If
Next
'This copies the data from the firm x the number of employees
j = 2
For i = 0 To UBound(emp, 2)
wou.Range(wou.Cells(j, 1), wou.Cells(j + UBound(firm, 1), 1)).Value = _
WorksheetFunction.Transpose(firm)
j = j + UBound(firm, 1)
Next i
'This copies the data from the activity labelled in the merged cells, it
should work if actNb was ok
k = 0
For i = 0 To UBound(emp, 2)
For j = 0 To UBound(act, 1)
wou.Range(wou.Cells(k + 2, 2), wou.Cells(actNb(j + 1) + 2 + k,
2)).Value = act(j)
k = k + actNb(j + 1)
Next j
Next i
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
So should someone help me fix the wrongdoing loop, this code will first
work with the first 2 columns.
As I said earlier, if you could manage to have your data re-arranged and
sorted in another way, because I really see this as the job of a pivot
table. More, at my vba level coding this with this code will require a few
more consistent loops. If your original data ever changes, a lot will have
to changed as well.
I'll be happy if I can get you with a final result but it will take some
more times unless someone comes with a fix or an easier solution.
Pascal Baro
--
--
FORUM RULES (986+ members already BANNED for violation)
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Cross-promotion of, or links to, forums competitive to this forum in
signatures are prohibited.
NOTE : Don't ever post personal or confidential data in a workbook. Forum
owners and members are not responsible for any loss.
------------------------------------------------------------------------------------------------------
To post to this group, send email to excel-macros@googlegroups.com
To unsubscribe, send a blank email to excel-macros+unsubscr...@googlegroups.com
