VBA code - copy, paste and delete on entire sheet

[Vishaal]

help please,

We have the following data where in data sheet we have multiple entry, we have also recored a macro and want to it will run in whole sheet, help please

we are copying the data Sheet1!C3:C6 and pasting as transpose on Sheet1!C2 and after that copying the Sheet1!G6 to Sheet1!G2 and after this deleting the row 2 to 6, we required to do it in whole sheet

Data Sheet

Ajay Bhai T.xlsx
	A	B	C	D	E	F	G
1	Number	Que	Option A	Option B	Option C	Option D	Answer
2	286	Solow’s paradox deals with the
3		(A)	Technology and labour
4		(B)	Labour and capital
5		(C)	Technology and productivity
6		(D)	Capital and productivity				C
7	287	Bond holder always suffer a capital
8		(A)	Discount, hold to maturity
9		(B)	Discount, sell before maturity
10		(C)	Premium, hold to maturity
11		(D)	Premium, sell before maturity				d
Sheet1

Result Sheet

Ajay Bhai T.xlsx
	A	B	C	D	E	F	G
1	Number	Que	Option A	Option B	Option C	Option D	Answer
2	286	Solow’s paradox deals with the	Technology and labour	Labour and capital	Technology and productivity	Capital and productivity	C
3	287	Bond holder always suffer a capital	Discount, hold to maturity	Discount, sell before maturity	Premium, hold to maturity	Premium, sell before maturity	d
Sheet2

macro

Sub Macro2()
'
' Macro2 Macro
'

'
    ActiveCell.Offset(-6, -3).Range("A1:A4").Select
    Selection.Copy
    ActiveCell.Offset(-1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveCell.Offset(4, 4).Range("A1").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveCell.Offset(-4, 0).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(1, 0).Rows("1:4").EntireRow.Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    ActiveCell.Offset(-1, 2).Range("A1").Select
End Sub

 

[mumps]

Try:

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim lRow As Long, fRow As Long, LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Range("C3:C" & LastRow).SpecialCells(xlCellTypeConstants)
        For i = .Areas.Count To 1 Step -1
            fRow = .Areas(i).Cells(1).Row
            lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            Range("C" & fRow - 1).Resize(, 4) = Application.Transpose(Range("C" & fRow & ":C" & lRow))
            Range("G" & fRow - 1) = Range("G" & lRow)
            Rows(fRow & ":" & lRow).Delete
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[Vishaal]

Thanks mumps
its working fine.

 

[mumps]

You are very welcome.