PDA

View Full Version : Can this be done with macro



caabdul
09-17-2013, 04:20 AM
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
09-17-2013, 04:51 AM
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
09-17-2013, 05:29 AM
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
09-17-2013, 05:46 AM
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
09-17-2013, 06:04 AM
Sorry I don't understand.Can you please send it done in that excel file? I am getting error at first line

Kenneth Hobs
09-17-2013, 06:28 AM
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
09-17-2013, 07:00 AM
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
09-17-2013, 09:05 AM
Thank you all the experts, It was a great help from all. Thank you