Copy Selected Filter and Paste to other sheet with different format

[deedii]

Hi guys, Im new to vba and i cant sort out this small problem. I am learning alone so im thankful for this wonderful community. Heres the scenario of my project.

I have two sheet in the workbook which is "Initial" and "Main". Those sheet is nearly the same format but in the Main sheet there is an additional column which are "zodiac, website and cellno." Users fill the "Initial" Sheet and I want to automate to copy the content from Initial to Main Sheet. The task is to filter and copy those data that has the same "City Address" in Initial Sheet and paste it in Main sheet. Pasting of data should be in the very last row. My problem is that when I run the Macro i recorded it always overwrite the previous entry.

Attached is the copy of my project.

Thanks in advance.

[nilem]

Maybe this is a better choice?
Sub ert()
With [a1].CurrentRegion
.Sort Key1:=.Cells(1, 4), Order1:=xlAscending, Header:=xlYes
End With
Range("C:C,E:E,F:F").Insert
Range("C1").Value = "Zodiac"
Range("F1").Value = "Website"
Range("H1").Value = "Cell No."
End Sub

[deedii]

I tried using this one

Sub TEST()
Dim r As Range, filt As Range
Worksheets("Initial").Activate
ActiveSheet.AutoFilterMode = False
Set r = Range("A1").CurrentRegion
r.AutoFilter
r.AutoFilter Field:=4, Criteria1:="52 Muenster"
Set filt = r.Offset(1, 0).Resize(r.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
filt.Copy Worksheets("main").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
ActiveSheet.AutoFilterMode = False
End Sub


but my problem is it should not duplicate and overwrite the existing data
new data must be inserted in the last row without duplication.

[deedii]

Maybe this is a better choice?
Sub ert()
With [a1].CurrentRegion
.Sort Key1:=.Cells(1, 4), Order1:=xlAscending, Header:=xlYes
End With
Range("C:C,E:E,F:F").Insert
Range("C1").Value = "Zodiac"
Range("F1").Value = "Website"
Range("H1").Value = "Cell No."
End Sub

I dont think so cause "Initial Sheet" format should not be change.
It should only copy the data that match the cell value in "Main Sheet"
and leave zodiac, website and cell no. blank as it has no value in Initial Sheet.

[nilem]

Сlippitch (http://www.vbaexpress.com/forum/member.php?u=42706)
can you show an example of the final result on a "Main Sheet"?

[deedii]

Attached is the file that shows the expected Final Output in the main sheet.
Thanks

[nilem]

maybe so
Sub TEST()
Dim i As Long
Application.ScreenUpdating = False
i = Worksheets("main").Cells(Rows.Count, "A").End(xlUp).Row + 1
With Worksheets("Initial").Range("A1").CurrentRegion
.AutoFilter
.AutoFilter Field:=4, Criteria1:="52 Muenster"
With .Offset(1)
.Columns(1).Resize(, 2).Copy Worksheets("main").Cells(i, 1)
.Columns(3).Resize(, 2).Copy Worksheets("main").Cells(i, 4)
.Columns(5).Copy Worksheets("main").Cells(i, 7)
.Columns(6).Resize(, 3).Copy Worksheets("main").Cells(i, 9)
End With
.AutoFilter
End With
Application.ScreenUpdating = True
End Sub

[deedii]

Yes that is perfect but how can i prevent it from duplicating existing data?
When i rerun the macro it duplicate existing data. I want to just update Main sheet with new data from initial sheet.
Thanksso much nilem :)

[nilem]

attempt number 3 :)
Sub TEST()
Dim x(), y(), rez(), i&, j&, lr&, s$

With Sheets("main")
x = .Range("A2:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
lr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
End With
With Sheets("Initial")
y = .Range("A2:H" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
ReDim rez(1 To UBound(y), 1 To 11)

On Error Resume Next
With New Collection
If IsArray(x) Then
For i = 1 To UBound(x)
s = Trim(x(i, 1)) & Trim(x(i, 2))
If IsEmpty(.Item(s)) Then .Add 0, s
Next i
End If

For i = 1 To UBound(y)
If Trim(y(i, 4)) = "52 Muenster" Then
s = Trim(y(i, 1)) & Trim(y(i, 2))
If IsEmpty(.Item(s)) Then
j = j + 1
rez(j, 1) = y(i, 1)
rez(j, 2) = y(i, 2)
rez(j, 4) = y(i, 3)
rez(j, 5) = y(i, 4)
rez(j, 7) = y(i, 5)
rez(j, 9) = y(i, 6)
rez(j, 10) = y(i, 7)
rez(j, 11) = y(i, 8)
End If
End If
Next i
End With

If j > 0 Then Sheets("main").Cells(lr, 1).Resize(j, 11).Value = rez()
End Sub

[deedii]

Ok it works. Thanks but can you please explain this to me so that I can use it in other docu in the future, coz when i integrate this to other problem, it works but the duplication still exist. Can you please explain the code to me? Thank you so much :)