Report using array?

Hi,

I am generating report based on unique values I have attached excel file for ur reference. Input is in Sheet1. I need output as in sheet2.

Thanks in advance

Regards,

Chandra Shekar

Chandrasheka,

With your raw data in Sheet1, the below macro will create a new worksheet Results per your request.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Adding the Macro
1. Copy the below macro, by highlighting the macro code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code:

---


Option Explicit
Sub CreateReport()
' stanleydgrom, 10/19/2010, VE34594
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
w1.Columns(3).Copy wR.Columns(1)
w1.Columns(2).Copy wR.Columns(2)
wR.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wR.Range("C1"), Unique:=True
wR.Columns("A:B").Delete
LR = wR.Cells.Find("*", , , , xlByRows, xlPrevious).Row
wR.Range("A2:B" & LR).Copy
wR.Range("C1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
wR.Columns("A:B").Delete
wR.Range("A1").Select
wR.Activate
Application.ScreenUpdating = True
End Sub

---

Then run the CreateReport macro.

ANother way

[vba]

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<<<< change to suit
Dim Lastrow As Long
Dim i As Long
Dim cell As Range

Application.ScreenUpdating = False

With ActiveSheet

Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row

For i = 3 To Lastrow

If .Cells(i - 1, "A").Value2 <> .Cells(i, "A").Value2 Then

.Cells(i, "C").Copy .Cells(2, .Columns.Count).End(xlToLeft).Offset(0, 1)
.Cells(i, "B").Copy .Cells(3, .Columns.Count).End(xlToLeft).Offset(0, 1)
Else

.Cells(i, "C").ClearContents
End If
Next i

.Cells(3, "C").Insert Shift:=xlToRight
.Cells(2, "B").Copy .Cells(3, "C")
.Columns("A:B").Delete
.Rows(4).Resize(Lastrow - 3).Delete
.Rows(1).Delete
End With

Application.ScreenUpdating = True
End Sub
[/vba]

Thank you all

Regards,

Chandra Shekar