Range Cut and paste using vba script

S

sreeinkorea

New Member
Joined
Sep 15, 2017
Messages
7
Hello,
I'm looking for a VBA script for the following scenario, kind request to suggest a method.

Ques:
I've a series of columns Range (A:HZ) (around 200 columns) with 10rows (fixed). I want to cut every 2 columns (following from C:D, E:F till HZ column) and concatenate the cut columns data below the first 2 columns (A:B) after 11th row(1 line space) and further paste other 2columns by leaving 1line space after every copy (beginning from 22nd row). Further move on towards right side of the remaining columns and keep concatenating below one after the other.


If any one can reply, then that shall reduce my editing time in excel and preparing the MS Word document.
Appreciate quick reply.
Thanking you.

Sorry i couldn't capture the snapshot or attach the file that I wanted to show, due to security reasons in my company.
I tried my best to create a table that I'm handling now, and the expected results as below.

<colgroup><col width="72" span="4" style="width: 54pt;"></colgroup><tbody>
</tbody>
AttributesContentsAttributesContentsAttributesContentsAttributesContentsAttributesContentsAttributesContents
Requirement ID1Requirement ID2Requirement ID3Requirement ID4Requirement ID5Requirement ID6
RequirementsabcRequirementsabcRequirementsabcRequirementsabcRequirementsabcRequirementsabc
System StateModeSystem StateModeSystem StateModeSystem StateModeSystem StateModeSystem StateMode
RationaleSRSRationaleSRSRationaleSRSRationaleSRSRationaleSRSRationaleSRS
PriorityM1PriorityM1PriorityM1PriorityM2PriorityM3PriorityM3
RiskTBDRiskTBDRiskTBDRiskTBDRiskTBDRiskTBD
Related IDTBDRelated IDTBDRelated IDTBDRelated IDTBDRelated IDTBDRelated IDTBD
StatusNAStatusNAStatusNAStatusNAStatusNAStatusNA
Verification CriteriaTBDVerification CriteriaTBDVerification CriteriaTBDVerification CriteriaTBDVerification CriteriaTBDVerification CriteriaTBD

<colgroup><col width="72" span="6" style="width:54pt"> <col width="72" span="5" style="width:54pt"> <col width="72" style="width:54pt"> </colgroup><tbody>
</tbody>



Expected Results
AttributesContents
Requirement ID2
Requirementsabc
System StateMode
RationaleSRS
PriorityM1
RiskTBD
Related IDTBD
StatusNA
Verification CriteriaTBD
AttributesContents
Requirement ID3
Requirementsabc
System StateMode
RationaleSRS
PriorityM1
RiskTBD
Related IDTBD
StatusNA
Verification CriteriaTBD
AttributesContents
Requirement ID4
Requirementsabc
System StateMode
RationaleSRS
PriorityM2
RiskTBD
Related IDTBD
StatusNA
Verification CriteriaTBD

<colgroup><col width="72" span="2" style="width:54pt"> </colgroup><tbody>
</tbody>


:
:
:
:

until all the columns towards right are concatenated one below the other with one line space after every copy.
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
Try the code below.
Hope it helps.


Code: 
Dim aStartTime
Dim strFullName As String
Dim ProcName As String
Dim bErrorHandle As Boolean
Const DblSpace As String = vbNewLine & vbNewLine
Const CoName As String = "Job Done"


Sub Test()
    Dim rng As Range, aCell As Range
    Dim iRow As Long, iCol As Long, iMaxCol As Long, iNextRow As Long
    Dim cCells As Range
    
    On Error GoTo errHandler
    bErrorHandle = False
    
    '~~> Start Timer
    aStartTime = Now()
    
    '~~> Speeding Up VBA Code
    Call SpeedUp(False)
    
    '~~> Define variables
    Set rng = Range("A1:L10")
    iRow = rng(rng.Rows.Count, 1).Row
    iCol = 1
    iMaxCol = rng.Columns.Count
    
    '~~> Delete Old Entries
    Rows("12:" & Application.Max(12, iRow)).EntireRow.Delete
    
    '~~> Let's Loop Cut data
    For iCol = 1 To iMaxCol Step 2
        Set cCells = Range(Cells(1, iCol), Cells(iRow, iCol)).Resize(iRow, 2)
        Set aCell = Cells(Range("A" & Rows.Count).End(xlUp).Row + 2, 1)
        
        cCells.Cut aCell
        Application.CutCopyMode = False
        
    Next iCol
    
BeforeExit:
    
    '~~> Remove items from memory
    Set rng = Nothing
    Set cCells = Nothing
    Set aCell = Nothing
    
    '~~> Speeding Up VBA Code
    Call SpeedUp(True)
    
    If bErrorHandle = False Then
        MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss") & vbNewLine _
            & DblSpace & " You're good to go!" & DblSpace & _
            CoName & Chr(32) & Chr(169) & Chr(32) & Year(Date), vbInformation, "Excellent"
    End If
    
    Exit Sub
errHandler:
    '~~> Error Occurred
    bErrorHandle = True
    ProcName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
    MsgBox "Procedure: - " & ProcName & DblSpace & Err.Description, vbCritical, "Oops I did it again...."
    Resume BeforeExit
    
End Sub



'#### SpeedUp (False) - Speeds the VBA Code #####
'#### SpeedUp (True) - Slows down the VBA Code ####
Public Function SpeedUp(Optional bSpeed As Boolean = True)
With Application
    .ScreenUpdating = bSpeed 'Prevent screen flickering
    .Calculation = IIf(bSpeed, xlAutomatic, xlCalculationManual) 'Preventing calculation
    .DisplayAlerts = bSpeed 'Turn OFF alerts
    .EnableEvents = bSpeed 'Prevent All Events
    '.Cursor = IIf(bSpeed, xlDefault, xlWait) 'Prevent Hour Glass
    '.StatusBar = IIf(bSpeed, vbNullString, "Please wait...")
End With
End Function
 
Last edited:
Upvote 0
Hello...
Thanks a ton, for such a wonderful piece of code... It worked exactly how I wanted to...

My apologies for the delayed reply. I really got held up with multiple tasks and couldn't reply.
Thanking you.
Sincerely,
Sree
 
Upvote 0
:)
Biz said:
Try the code below.
Hope it helps.


Code: 
Dim aStartTime
Dim strFullName As String
Dim ProcName As String
Dim bErrorHandle As Boolean
Const DblSpace As String = vbNewLine & vbNewLine
Const CoName As String = "Job Done"


Sub Test()
    Dim rng As Range, aCell As Range
    Dim iRow As Long, iCol As Long, iMaxCol As Long, iNextRow As Long
    Dim cCells As Range
    
    On Error GoTo errHandler
    bErrorHandle = False
    
    '~~> Start Timer
    aStartTime = Now()
    
    '~~> Speeding Up VBA Code
    Call SpeedUp(False)
    
    '~~> Define variables
    Set rng = Range("A1:L10")
    iRow = rng(rng.Rows.Count, 1).Row
    iCol = 1
    iMaxCol = rng.Columns.Count
    
    '~~> Delete Old Entries
    Rows("12:" & Application.Max(12, iRow)).EntireRow.Delete
    
    '~~> Let's Loop Cut data
    For iCol = 1 To iMaxCol Step 2
        Set cCells = Range(Cells(1, iCol), Cells(iRow, iCol)).Resize(iRow, 2)
        Set aCell = Cells(Range("A" & Rows.Count).End(xlUp).Row + 2, 1)
        
        cCells.Cut aCell
        Application.CutCopyMode = False
        
    Next iCol
    
BeforeExit:
    
    '~~> Remove items from memory
    Set rng = Nothing
    Set cCells = Nothing
    Set aCell = Nothing
    
    '~~> Speeding Up VBA Code
    Call SpeedUp(True)
    
    If bErrorHandle = False Then
        MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss") & vbNewLine _
            & DblSpace & " You're good to go!" & DblSpace & _
            CoName & Chr(32) & Chr(169) & Chr(32) & Year(Date), vbInformation, "Excellent"
    End If
    
    Exit Sub
errHandler:
    '~~> Error Occurred
    bErrorHandle = True
    ProcName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
    MsgBox "Procedure: - " & ProcName & DblSpace & Err.Description, vbCritical, "Oops I did it again...."
    Resume BeforeExit
    
End Sub



'#### SpeedUp (False) - Speeds the VBA Code #####
'#### SpeedUp (True) - Slows down the VBA Code ####
Public Function SpeedUp(Optional bSpeed As Boolean = True)
With Application
    .ScreenUpdating = bSpeed 'Prevent screen flickering
    .Calculation = IIf(bSpeed, xlAutomatic, xlCalculationManual) 'Preventing calculation
    .DisplayAlerts = bSpeed 'Turn OFF alerts
    .EnableEvents = bSpeed 'Prevent All Events
    '.Cursor = IIf(bSpeed, xlDefault, xlWait) 'Prevent Hour Glass
    '.StatusBar = IIf(bSpeed, vbNullString, "Please wait...")
End With
End Function
Click to expand...
 
Upvote 0
sreeinkorea said:
Hello...
Thanks a ton, for such a wonderful piece of code... It worked exactly how I wanted to...

My apologies for the delayed reply. I really got held up with multiple tasks and couldn't reply.
Thanking you.
Sincerely,
Sree
Click to expand...

No problems, I'm glad it solved your problem.

Biz
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
Join data from second worksheet with delimited list values (mults) to another worksheet with one value per cell/row and keep 1:1 relationship
Replies
2
Views
1K
HeadAgainstABrickWall
H
A
  • Question
Web Scraping using VBA
Replies
4
Views
9K
atr140
A
M
  • Question
Using VBA to return data before the last hyphen
2
Replies
11
Views
1K
mrpavlos
M
M
  • Question
extract-all-rows-from-a-range-that-meet-criteria-in-one-column-in-excel using vba
Replies
5
Views
9K
RasGhul
RasGhul
P
  • Question
Automate creating a worksheet adding rows based on certain criterias (all this in the same workbook)
Replies
1
Views
667
pratikjoshi448
P

Forum statistics

Threads
1,215,772
Messages
6,126,800
Members
449,337
Latest member
BBV123

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top