View Full Version : Solved: Macro for Insertion of Lines between data
kevindbn
02-08-2010, 05:04 AM
Hi Guys
I have a spreadsheet with the following data:
A001 6009896523
A001 6006587455
A002 6009658544
A002 6008745632
A002 6009874456
A003
etc
etc and the Alphabets in the 1st coloum can change to "B001" etc and so forth.
My spreadsheet starts from A001 and A001 can go up to T009, with variables in betweeen. The spreadsheet will follow Alphabetic numeric order. I currently have to manually insert 5 lines after each lot of A001's A002's etc . Can I have this automatically inserted after every Aphanumeric field.eg afer all the A001's insert 5 blank lines, after all the A002's, A003's etc in need 5 blank lines to be inserted.
There is no set numbers as they vaiy so i need a macro that will be able to check that as the number changes leave 5 lines... can anyone help please....
Thanks...
Kevin
Hi Guys
I have a spreadsheet with the following data:
A001 6009896523
A001 6006587455
A002 6009658544
A002 6008745632
A002 6009874456
A003
etc
etc and the Alphabets in the 1st coloum can change to "B001" etc and so forth.
Greetings Kevin,
Welcome to vbaexpress :hi:
Just to clarify, in the above, A001 is in one column, and 6009896523 is in the next column?
Mark
kevindbn
02-08-2010, 05:59 AM
Greetings Kevin,
Welcome to vbaexpress :hi:
Just to clarify, in the above, A001 is in one column, and 6009896523 is in the next column?
Mark
Thanks for the welcome Mark
Thats correct Mark.
Not well tested, but in a junk copy of your wb, try:
Option Explicit
Sub exa()
Dim lLRow As Long
Dim i As Long
Dim strCurVal
lLRow = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = lLRow To 2 Step -1
If strCurVal = vbNullString Then
strCurVal = Cells(i, 1).Value
GoTo Skip
End If
If Not Cells(i, 1).Value = strCurVal Then
strCurVal = Cells(i, 1).Value
Rows(i + 1 & ":" & i + 5).Insert xlShiftDown
End If
Skip:
Next
Application.ScreenUpdating = True
End Sub
Hope that helps,
Mark
kevindbn
02-08-2010, 08:17 AM
Not well tested, but in a junk copy of your wb, try:
Option Explicit
Sub exa()
Dim lLRow As Long
Dim i As Long
Dim strCurVal
lLRow = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = lLRow To 2 Step -1
If strCurVal = vbNullString Then
strCurVal = Cells(i, 1).Value
GoTo Skip
End If
If Not Cells(i, 1).Value = strCurVal Then
strCurVal = Cells(i, 1).Value
Rows(i + 1 & ":" & i + 5).Insert xlShiftDown
End If
Skip:
Next
Application.ScreenUpdating = True
End Sub
Hope that helps,
Mark
Thank you so much Mark.... worked like a dream..:thumb :thumb :thumb :thumb
really appreciate it.
Take care...
Kevin:beerchug:
Hi Kevin,
To answer your request for an explanation, see if these comments in the code help :-)
Sub exa()
Dim lLRow As Long
Dim i As Long
Dim strCurVal
'// Find the last cell with data. //
lLRow = Cells(Rows.Count, 1).End(xlUp).Row
'// Kill screen repaints to speed up macro and stop eyes from bleeding... //
Application.ScreenUpdating = False
'// Loop from bottom row w/data to row 2 (presumes a header row). //
For i = lLRow To 2 Step -1
'// You should actually be able to move this above the loop and just use//
'// strCurVal = Cells(lLRow, 1).Value //
'// As written, we get a 'seed' value if you will. //
If strCurVal = vbNullString Then
strCurVal = Cells(i, 1).Value
GoTo Skip
End If
'// For all loops excepting the first lap, we check to see if the cell's//
'// value is different than the cells below. If it is, and as you have //
'// your alphanumeric vals grouped/sorted, then we can presume that teh //
'// different val indicates the last of a different record //
If Not Cells(i, 1).Value = strCurVal Then
strCurVal = Cells(i, 1).Value
Rows(i + 1 & ":" & i + 5).Insert xlShiftDown
End If
Skip:
Next
Application.ScreenUpdating = True
End Sub
Hope that helps,
Mark
drawworkhome
02-09-2010, 07:42 AM
hey mark you sent it to erik?
hey mark you sent it to erik?
:doh:Errr? Not sure what I did, as I deleted PMs, but evidently my bad.
Sorry about that. :(
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.