Hi Rasheed,
>
You can find below the complete code. I can't send a workbook now as there
are modules and few sheets non relevant. With the new code, I have the
following modifications:
- it will create 2 new worksheets (a temporary original copy of your data
and another sheet output2) provided you delete the one created by the code
after you run the code
- the data is now coherent with the number of employees (base 0 and 1 array
like counting on fingers, most Excel objects start from 1 while Excel
variable such as arrays and collection start by default at 0 I think or the
other way around and by default the computer start from 0 to store data in
memory. I got confused there and was not able to realize that until you
told me, sorry for that and thank for your notice.
At last if you can realize that you're ignorant, I'll be careful with you,
you know more than what you think and want to tell !!!
Please find the code below, I'll look for the column related to FS and
related data and Employee names as well afterwards as the code is almost
complete. If by then someone reading this can provide that with his code or
based on my code, it would be nice as I'm learning vba scripts.
---
Public wOriginal As Worksheet
Public wOrig2 As Worksheet
Public wOut As Worksheet
Sub Layout2()
Dim hdr() 'Header for output2 sheet
Dim Emp() 'stores employee name from Original_tmp Sheet
Dim MCell() 'stores merged cells address
Dim r As Range
Dim lastc As Long 'Last column in the employee range
Dim NBEMP As Long 'Number of employee (iteration limit for the main loop)
Dim lastr As Long 'Number of row
Set wOriginal = ThisWorkbook.Worksheets("Original")
ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name =
"Original_tmp" 'comment this line out if the sheet already exists or delete
the sheet
Set wOrig2 = ThisWorkbook.Worksheets("Original_tmp")
ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name =
"Output2" ' 'comment this line out if the sheet already exists
Set wOut = ThisWorkbook.Worksheets("Output2")
wOriginal.Cells.Copy wOrig2.Cells
'Last row
lastr = wOrig2.Cells(Rows.Count, 1).End(xlUp).Row
'Range related to the first column of the source data to work out
Set r = wOrig2.Range(wOrig2.Cells(10, 1), wOrig2.Cells(lastr, 1))
'Formatting and layout stuff
hdr = Array("Firm", "Category", "Activity", "No", "Capacity", "Rating",
"Name", "Hours", "EOM")
wOut.Range("A1:I1") = hdr
wOut.Range("A1:I1").Font.Bold = True
wOut.Range("A1:I1").Interior.Color = 65535
'Last column in the employee range in the original data header row
lastc = wOrig2.Cells(4, Columns.Count).End(xlToLeft).Column
NBEMP = lastc - 5
'COPY PASTE DATA FROM NON-MERGED COLUMNS AND RETURNS MERGED CELLS ROW
NUMBERS IN AN ARRAY
MCell() = CopyFirstCol(r, wOut, NBEMP)
End Sub
Function CopyFirstCol(rg As Range, wsB As Worksheet, NEMP As Long)
'
'This function both copies pastes columns and return an array with merged
cells row numbers
'
Dim c As Range
Dim MCellV() 'Array to store merged cells values
Dim MCellA() 'Array to store merged cells addresses or row numbers
Dim Firm() 'Array to store col 1
Dim Activity() 'Array to store col 2
Dim No() 'Array to store col 4
Dim Capacity() 'Array to store col 5
Dim Rating() 'Array to store col 6
Dim i As Long, j As Long
Dim N As Long
i = 0
ReDim MCellV(i)
ReDim MCellA(i)
j = 0
ReDim Firm(j)
ReDim Activity(j)
ReDim No(j)
ReDim Capacity(j)
ReDim Rating(j)
For Each c In rg
If c.MergeCells Then
MCellV(i) = c.Value
MCellA(i) = c.Row - 9
i = i + 1
ReDim Preserve MCellV(i)
ReDim Preserve MCellA(i)
Else
Firm(j) = c.Value
Activity(j) = c.Offset(, 1).Value
No(j) = c.Offset(, 2).Value
If c.Offset(, 2).Value = vbNullString Then No(j) = "NA"
Capacity(j) = c.Offset(, 3).Value
If c.Offset(, 3).Value = vbNullString Then Capacity(j) = "NA"
Rating(j) = c.Offset(, 4).Value
If c.Offset(, 4).Value = vbNullString Then Rating(j) = "NA"
j = j + 1
ReDim Preserve Firm(j)
ReDim Preserve Activity(j)
ReDim Preserve No(j)
ReDim Preserve Capacity(j)
ReDim Preserve Rating(j)
End If
Next c
N = j
ReDim Preserve MCellV(i - 1)
ReDim Preserve MCellA(i - 1)
ReDim Preserve Firm(j - 1)
ReDim Preserve Activity(j - 1)
ReDim Preserve No(j - 1)
ReDim Preserve Capacity(j - 1)
ReDim Preserve Rating(j - 1)
'This copies the data from the firm x the number of employees
j = 2
For i = 1 To NEMP
wsB.Range(wsB.Cells(j, 1), wsB.Cells(j + N, 1)).Value = _
WorksheetFunction.Transpose(Firm)
wsB.Range(wsB.Cells(j, 3), wsB.Cells(j + N, 3)).Value = _
WorksheetFunction.Transpose(Activity)
wsB.Range(wsB.Cells(j, 4), wsB.Cells(j + N, 4)).Value = _
WorksheetFunction.Transpose(No)
wsB.Range(wsB.Cells(j, 5), wsB.Cells(j + N, 5)).Value = _
WorksheetFunction.Transpose(Capacity)
wsB.Range(wsB.Cells(j, 6), wsB.Cells(j + N, 6)).Value = _
WorksheetFunction.Transpose(Rating)
j = j + N
Next i
CopyFirstCol = MCellA
End Function
---
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
