Hi Pascal,
Thanks for the code.
I changed the code according to my limited knowledge..
I think I missed something probably..pardon me for my ignorance
When I run the code it gives an error...
Block If without and EndIf and highlights End Function
Can you please paste the whole code
This is the complete code after I have changed it.
Public wOriginal As Worksheet
Public wOrig2 As Worksheet
Public wOut As Worksheet
Sub Layout()
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:=wOriginal).Name = "Original_tmp"
'comment this line out if the sheet already exists
Set wOrig2 = ThisWorkbook.Worksheets("Original_tmp")
ThisWorkbook.Worksheets.Add(After:=wOriginal).Name = "Output2" ' 'comment
this line out if the sheet already exists
Set wOut = ThisWorkbook.Worksheets("Output2")
'Last row
lastr = wOrig2.Cells(Rows.Count, 1).End(xlUp).Row
Set r = wOrig2.Range(wOrig2.Cells(10, 1), wOrig2.Cells(lastr, 1))
wOriginal.Cells.Copy wOrig2.Cells
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 THE FIRST COLUMN "FIRM" AND RETURNS MERGED CELLS ROW NUMBERS
MCell() = CopyFirstCol(r, wOut, NBEMP)
End Sub
Function CopyFirstCol(rg As Range, wsB As Worksheet, NEMP As Long)
'
'This function both copies pastes columns 1 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 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
On Friday, July 27, 2012 7:12:06 PM UTC+4, bpascal123 wrote:
> quick fix in the function... base 0 - base 1 arrays confusion fixed.
> however, the last row comes with garbage data #NA why so?
>
> Function CopyFirstCol(rg As Range, wsB As Worksheet, NEMP As Long)
> '
> 'This function both copies pastes columns 1 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
> bpascal...@gmail.com
>
--
--
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
