Trying to Split and delete

[Prakash]

Hi Experts,

Here is what I'm trying to do and my code.
1.
I have a table (which is dynamic and will change from Project to Project so
I can NOT HARD CODE THE MACRO)
Col A Col B Col C
Month Planned Actual Row# 1
Jan 50 48 Row# 2
Feb 55 54 Row# 3
Mar 58 60 Row# 4
Apr 60 62 Row# 5
May 65 65 Row# 6
Jun 68 65 Row# 7
Jul 75 70 Row# 8
Aug 85 84 Row# 9
Sep 100 95 Row# 10

2. User runs the macro and the required out put is

Col A Col D Col E Col F Col G
Date Planned 1 Actual 1 Planned 2 Actual 2
Jan 50 48
55 54
58 60
Apr 60 62 60 62
65 65
68 65
75 70
85 84
Sep 100 95

User will select a ROW by Clicking on the row# on the worksheet ONE TIME. So
that the corresponding values in the column against that ROW sould be used
for these alignments.
3. My code below does 50% of the requirement.
4. Request you to help. Thanks in advance...
----------------------------------------
My code

Sub Test()
'
'
' Let user select a row of values by clicking on the row number listed
on the work sheet

Dim Rng As Range
On Error Resume Next
Set Rng = Application.InputBox(prompt:="PLEASE CLICK ON THE ROW NUMBERS
LISTED on THE LEFT HAND SIDE TO SELECT A ROW", Type:=8)
If Rng Is Nothing Then
MsgBox "Operation Cancelled"
Else
Rng.Select
With Selection.Interior
.ColorIndex = 7
.Pattern = xlSolid
End With
''''''''''''''''''''''''''''
'Populating project date fields from column A

Dim kLastRow As Long
Dim k As Long

kLastRow = Cells(Rows.Count, "A").End(xlUp).Row
If Not Rng Is Nothing Then
Range("A2").Copy Range("E2")
Rng.Copy Cells(Rng.Row, "E")
'Cells(kLastRow, "A").Copy Cells(kLastRow, "E")
End If

''''''''''''''''''''''''''''''''''
'Populating column F and Col G

Dim jLastRow As Long
Dim j As Long

jLastRow = Cells(Rows.Count, "B").End(xlUp).Row
Range("B1").Resize(Rng.Row).Copy Range("F1")
Rng.Offset(1, 0).Resize(iLastRow - Rng.Row).Copy Range("G2")

'Populating column H and Col I

Dim lLastRow As Long
Dim l As Long

lLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("C1").Resize(Rng.Row).Copy Range("H1")
Rng.Offset(1, 0).Resize(iLastRow - Rng.Row).Copy Range("I2")

End If

End Sub
------------------------------------------------------------------------

 

[Allllen]

Prakash,

Your macro doesn't put the data in quite the same columns as your required
output was suggesting.

Have a go with this and see what you think.

Sub Test()

Dim Rng As Range, iSelectedRow As Integer, iLastRow As Integer, readrow As
Integer

'Use your method to get the row, and colour it purple
On Error Resume Next
Set Rng = Application.InputBox(prompt:="PLEASE CLICK ON THE ROW NUMBERS
LISTED on THE LEFT HAND SIDE TO SELECT A ROW", Type:=8)
If Rng Is Nothing Then MsgBox "Operation Cancelled": Exit Sub Else:
Rng.Interior.ColorIndex = 7
On Error GoTo 0
iSelectedRow = Rng.Row

'Find the last row in column A
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
If iSelectedRow > iLastRow Then MsgBox ("The row must be in the table"):
Exit Sub

'Write the headers for your table
Range("e1").Value = "Date": Range("e1").Interior.ColorIndex =
Range("a1").Interior.ColorIndex
Range("f1").Value = "Planned1": Range("f1").Interior.ColorIndex =
Range("b1").Interior.ColorIndex
Range("g1").Value = "Actual1": Range("g1").Interior.ColorIndex =
Range("c1").Interior.ColorIndex
Range("h1").Value = "Planned2": Range("h1").Interior.ColorIndex =
Range("b1").Interior.ColorIndex
Range("i1").Value = "Actual2": Range("i1").Interior.ColorIndex =
Range("c1").Interior.ColorIndex

'Write your table
For readrow = 2 To iLastRow
If readrow = 2 Or readrow = iSelectedRow Or readrow = iLastRow Then
Cells(readrow, 5) = Cells(readrow, 1)
If readrow <= iSelectedRow Then
Cells(readrow, 6) = Cells(readrow, 2)
Cells(readrow, 7) = Cells(readrow, 3)
End If
If readrow >= iSelectedRow Then
Cells(readrow, 8) = Cells(readrow, 2)
Cells(readrow, 9) = Cells(readrow, 3)
End If
Next readrow

End Sub