Assistance needed writing macro to insert rows

[red5030]

Hi all!

I have limited exposure to macros and was hoping to receive some assistance.

My original data sheet has 43,000 rows and 44 columns. First, I must execute a custom sort of 16 columns. Second, whenever one cell is not identical to the cell above it (for 15 of the 16 sorted columns), I need to insert a blank row. Manually, this will take weeks.

Here is an example of the logic that I'm trying to use:

=IF(AND(A3=A4,B3=B4,C3=C4,D3=D4,E3=E4,F3=F4,G3=G4,H3=H4,I3=I4,G3=G4,H3=H4,I3=I4,J3=J4,=K3=K4,L3=L4,M3=M4,N3=N4,R3=R4),Do Nothing, Insert Row below Row 3).

Would someone who is well educated in marcos be able to write such a thing?

Please advise,
Ross

 

[venkat1926]

a sample data (trivial) is in sheet1 which is copied to sheet2 for preserving original data

Sheet1

*	A	B	C
1	*	*	*
2	*	*	*
3	1	2	3
4	1	2	3
5	2	3	4
6	3	4	5
7	3	4	5
8	4	5	6

<colgroup><col style="font-weight:bold; width:30px; "><col style="width:64px;"><col style="width:64px;"><col style="width:64px;"></colgroup><tbody>
</tbody>

Excel tables to the web >> Excel Jeanie HTML 4

f
one function and three macros are given. But run ONLY final_macro on the given data.

later modify the macro "concat" and "insert_rows" to suit your data and requirements.

'[courtesy: NBVC OzMVP




Function aconcat(a As Variant, Optional sep As String = "") As String
     ' Harlan Grove, Mar 2002
    Dim y As Variant
     
    If TypeOf a Is Range Then
        For Each y In a.Cells
            aconcat = aconcat & y.Value & sep
        Next y
    ElseIf IsArray(a) Then
        For Each y In a
            aconcat = aconcat & y & sep
        Next y
    Else
        aconcat = aconcat & a & sep
    End If
     
    aconcat = Left(aconcat, Len(aconcat) - Len(sep))
End Function

Sub concat()
Dim r As Range, dest As Range
Worksheets("sheet1").Activate
Set r = Range("A3:C3")
Set dest = Range("D3")
Do
dest = aconcat(r)
'MsgBox dest
Set r = r.Offset(1, 0)
Set dest = dest.Offset(1, 0)
If r.Row > Range("A3").End(xlDown).Row Then Exit Do
Loop
End Sub

Sub inserting_row()
Dim j As Long, k As Long
j = Range("D3").End(xlDown).Row
For k = j To 3 Step -1
If Cells(k, "D") = Cells(k - 1, "D") Then Cells(k + 1, "D").EntireRow.Insert
Next k
End Sub

Sub final_macro()
Worksheets("sheet1").Cells.Clear
Worksheets("sheet2").Cells.Copy Worksheets("sheet1").Range("A1")
concat
inserting_row
End Sub