Appending Data

[manrique83]

Tek-Tippers,
I have the following macro. I want to append the 3rd cell from the new record to the 3rd cell of the current record if all the cells in the new record are equal to the cells of the old record(but not cell(_,3). I thought this would do it but I'm getting a runtime error(Type Mismatch), but all my cells were formatted as 'Text'

Can someone please help?
-------------------------------------------
Option Explicit

Sub Delete_Duplicate()
Dim current As Worksheet
Set current = ActiveWorkbook.ActiveSheet
Dim iRow As Integer
iRow = 2
With current
Do Until .Cells(iRow, 1) = ""
If (.Cells(iRow, 1) = .Cells(iRow - 1, 1) And _
.Cells(iRow, 2) = .Cells(iRow - 1, 2) And _
.Cells(iRow, 4) = .Cells(iRow - 1, 4) And _
.Cells(iRow, 5) = .Cells(iRow - 1, 5) And _
.Cells(iRow, 6) = .Cells(iRow - 1, 6) And _
.Cells(iRow, 7) = .Cells(iRow - 1, 7) And _
.Cells(iRow, 8) = .Cells(iRow - 1, 8) And _
.Cells(iRow, 9) = .Cells(iRow - 1, 9) And _
.Cells(iRow, 10) = .Cells(iRow - 1, 10) And _
.Cells(iRow, 11) = .Cells(iRow - 1, 11)) Then _
.Cells(iRow, 3).Value = .Cells(iRow, 3).Value _
& ", " & .Cells(iRow - 1, 3).Value And _
.Rows(iRow - 1).Delete Else: iRow = iRow + 1
Application.StatusBar = "Row: " + CStr(iRow)
Loop
End With
Application.ScreenUpdating = True
Application.StatusBar = False
Set current = Nothing
End Sub

 

[SkipVought]

Hi,

You have TWO problems:

1) Deletes should ALWAYS be pweformed from the BOTTOM UP or you run into the chance of loosing reference of where you are.

2) therefore DECRIMENT iRow

2) here's some simplified code

    If All_That_Stuff_Is_True Then
        .Cells(iRow, 3).Value = .Cells(iRow, 3).Value _
            & ", " & .Cells(iRow - 1, 3).Value

        .Rows(iRow - 1).Delete
    Else
        iRow = iRow - 1
    End If

Skip,

_{[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL!}

 

[manrique83]

So are you saying I should initially set iRow to the last record in the worksheet?

If that's so, then I still get a " Run-time error '13': Type mismatch

Option Explicit

Sub Delete_Duplicate()
Dim current As Worksheet
Set current = ActiveWorkbook.ActiveSheet
Dim iRow As Integer
iRow = 19792
With current
Do Until .Cells(iRow, 1) = ""
If (.Cells(iRow, 1) = .Cells(iRow - 1, 1) And _
.Cells(iRow, 2) = .Cells(iRow - 1, 2) And _
.Cells(iRow, 4) = .Cells(iRow - 1, 4) And _
.Cells(iRow, 5) = .Cells(iRow - 1, 5) And _
.Cells(iRow, 6) = .Cells(iRow - 1, 6) And _
.Cells(iRow, 7) = .Cells(iRow - 1, 7) And _
.Cells(iRow, 8) = .Cells(iRow - 1, 8) And _
.Cells(iRow, 9) = .Cells(iRow - 1, 9) And _
.Cells(iRow, 10) = .Cells(iRow - 1, 10) And _
.Cells(iRow, 11) = .Cells(iRow - 1, 11)) Then _
.Cells(iRow, 3).Value = .Cells(iRow, 3).Value _
& ", " & .Cells(iRow - 1, 3).Value And _
.Rows(iRow - 1).Delete _
Else: iRow = iRow - 1
Application.StatusBar = "Row: " + CStr(iRow)
Loop
End With
Application.ScreenUpdating = True
Application.StatusBar = False
Set current = Nothing
End Sub

 

[SkipVought]

    If All_That_Stuff_Is_True Then    [b][red]'NO CONTINUATION!!!!![/red][/b]
        .Cells(iRow, 3).Value = .Cells(iRow, 3).Value _
            & ", " & .Cells(iRow - 1, 3).Value
[b][red]'NO And!!!!![/red][/b]
        .Rows(iRow - 1).Delete
    Else
        iRow = iRow - 1
    End If

Skip,

_{[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL!}