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
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.
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]
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
Thank you all
Regards,
Chandra Shekar