Can this be done with macro

[caabdul]

Hello Dear Experts, I can do the following without macro, can it be done with a macro?

I have searched a lot of information on web and have really not been able to make a macro that does the following things:

1> Remove duplicate rows based on data ID in column A.
2> Insert data in columns C, D and E of from other three sheets, based on ID.

I have used For Loop but it does not work for unknown number of rows.


Pleease Help

Thank you all

[mrojas]

Your attached file has nothing but an incomplete routine in Module1.

I thought you said you can do things without a macro?

Please elaborate.

In the mean time, here's how you would determine the number of rows in a given range.
As with everything in life, there's more than one way to do this.

Private Function f_CountRowsInRange(strColumn As String, lngEnd As Long, intSheet As Integer) As Long
    On Error GoTo ErrorTrap
    
    Sheets(intSheet).Select
    For Each rw In Worksheets(intSheet).Rows
        ' Gone one cell too far, or there's an empty cell between first and last cell in range
        If (IsEmpty(Range(strColumn & lngEnd)) = True) Or (IsNumeric(Range("H" & lngEnd)) = False) Or (IsEmpty(Range("H" & lngEnd)) = True) Then
            lngEnd = lngEnd - 1
            Exit For
        End If
        lngEnd = lngEnd + 1
    Next rw
ExitPoint:
    f_CountRowsInRange = lngEnd
    Exit Function
ErrorTrap:
    MsgBox "f_CountRowsInRange: Sheet " & intSheet & ", row number " & lngEnd & ", " & Err.Description, vbExclamation, "Error"
    lngEnd = 0
    GoTo ExitPoint
End Function

The way to use this function is by calling it from, say a macro subroutine, passing it some parameters:
dim lngRowsSheet1 as long
lngRowsSheet1 = f_CountRowsInRange("A", 2, 1)

[caabdul]

Sorry I don't know much about Macros, I couldn't understand your code.

Earlier I made something like following code

Sub DupRemov()
For i = 2 to 10
a = cells(i, 1).Value
b = cells(i+1, 1).Value
If a = b Then
Rows.(i+1).Delete
i = i-1
End If
Next i
End Sub

But there was a drawback with this code that it didn't work where number of rows was more than 10 (unknown)

[mrojas]

Ok, replace all your code with the following:

Private Sub s_CountRows
Dim lngEnd as Long
lngEnd = 2
' This loop counts cells with values in it
For Each rw In Worksheets(1).Rows
' Gone one cell too far, or there's an empty cell between first and last cell in range
If (IsEmpty(Range("A" & lngEnd)) = True) Then
lngEnd = lngEnd - 1
Exit For
End If
lngEnd = lngEnd + 1
Next rw
' Now call your remove duplicates routine
Call s_RemoveDuplicates(lngEnd)
End Sub

Sub s_RemoveDuplicates(lngEnd as long)
For i = 2 to lngEnd
a = cells(i, 1).Value
b = cells(i+1, 1).Value
If a = b Then
Rows.(i+1).Delete
i = i-1
End If
Next i
End Sub

Now your starting point is the s_CountRows routine. Make sure your macro invokes this routine.

[caabdul]

Sorry I don't understand.Can you please send it done in that excel file? I am getting error at first line

[Kenneth Hobs]

Welcome to the forum!

Please make future post's subject line more descriptive. e.g. Remove Duplicate Rows and Add Formulas

Sub Main()
  'Remove fully duplicate rows
  'Worksheets("Main").UsedRange.RemoveDuplicates Array(1, 2), xlNo
  DelRowsByDupsInColA "Main"
  AddFormulas
End Sub

Sub DelRowsByDupsInColA(aWS As String)
    Dim iRow As Long
    With Worksheets(aWS)
        For iRow = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
            With .Cells(iRow, "A")
                If .Value = .Offset(-1).Value Then .EntireRow.Delete
            End With
        Next iRow
    End With
End Sub

Sub AddFormulas()
  Dim r As Range, c As Range
  Dim lr As Long, a(1 To 3) As String, i As Integer, s As String
  
  With Worksheets("Main")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    a(1) = .Range("C1").Value2
    a(2) = .Range("D1").Value2
    a(3) = .Range("E1").Value2
    For i = LBound(a) To UBound(a)
      s = "=vLookup(A2," & a(i) & "!" & Worksheets(a(i)).UsedRange.Address & ", 2, FALSE)"
      .Range("B2").Offset(0, i).Formula = s
    Next i
    .Range("C2:E2").Copy .Range("C3:E" & lr)
    .Range("C:E").Columns.AutoFit
  End With
End Sub

[Paul_Hossler]

One way

Option Explicit
Sub AddData()
    Dim rID As Range, rIDwithoutRow1 As Range, rRow As Range

    With ActiveWorkbook.Worksheets("Main")
        'remove duplicate ID's from Main
        .Cells(1, 1).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
    
        '.CurrentRegion selects everything around (1,1) or A1
        Set rID = .Cells(1, 1).CurrentRegion
        
        '.Resize this way gives rows 2 to last one
        Set rIDwithoutRow1 = rID.Cells(2, 1).Resize(rID.Rows.Count - 1, rID.Columns.Count)
    
        'sort by ID
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("A1"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        
            .SetRange rIDwithoutRow1
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    'go down through the data rows
    For Each rRow In rIDwithoutRow1.Rows
        With rRow
            'continue if not found
            On Error Resume Next
            .Cells(3).Value = Application.WorksheetFunction.VLookup(.Cells(1).Value, Worksheets("Interests").Cells(1, 1).CurrentRegion, 2, False)
            .Cells(4).Value = Application.WorksheetFunction.VLookup(.Cells(1).Value, Worksheets("Activities").Cells(1, 1).CurrentRegion, 2, False)
            .Cells(5).Value = Application.WorksheetFunction.VLookup(.Cells(1).Value, Worksheets("Languages").Cells(1, 1).CurrentRegion, 2, False)
            On Error GoTo 0
        End With
    Next
End Sub

Paul

[caabdul]

Thank you all the experts, It was a great help from all. Thank you