[RESOLVED] Can you help to complete this code

[nader]

In the first Ihope to be clear
This code only is to copy the values one time so if there are a another same value it will not copy them as it show in the pic1

Dim cell As Range 
Set myRange3 = Worksheets(2).Range("A1:A100") 
 
For Each cell In myRange3 
    If IsError(Application.Match(cell.Value, Sheets(3).Columns(1), 0)) Then 
        R = Sheets(3).UsedRange.Rows.Count 
        If R <> 1 Or Sheets(3).Range("A1").Value <> "" Then R = R + 1 
        cell.Copy Sheets(3).Range("a" & R) 
    End If 
Next cell

I want a new code to copy four values in same row one time, and if there is one difference value at least it will print the four vlaues again . As it show in the pic2, where in the rwo 5 Tom,25,Green,Italy it's difference than Tom,25,Green,England are difference in Italy so it will copy . In the 6 and 7 rows are the same values as it in the 1 and 2 rwos.

So I tried this code but it didn't success with me

 Dim cell As Range
Set myRange3 = Worksheets(2).Range("A1:D100")
 
For Each cell In myRange3
    If IsError(Application.Match(cell.Value, Sheets(3).Columns(1) And Sheets(3).Columns(2) And Sheets(3).Columns(3) And Sheets(3).Columns(4), 0)) Then
        R = Sheets(3).UsedRange.Rows.Count
        If R <> 1 Or Sheets(3).Range("A1").Value <> "" Then R = R + 1
        cell.Copy Sheets(3).Range("a" & R)
         cell.Copy Sheets(3).Range("b" & R)
          cell.Copy Sheets(3).Range("c" & R)
           cell.Copy Sheets(3).Range("d" & R)
    End If
Next cell

So how to do it?

[BManke]

Is it necessary to do this in code? Or do you just need to get it done?

There would be the option to simply open the XL-Sheet in the new Excel 2007. The tab "Data" has the built-in function "remove duplicates"

hth

BManke

[nader]

Yes it is necessary to do this in code.

[BManke]

Make two named ranges. Can be on two different sheets or on one sheet. Your choice. One is source the other target, let's call them sourcerange and targetrange. They will have to be the same size, have correct headers and so on.

Then use ADO to establish a database connection and use an SQL query with a DISTINCT query.


www.connectionstrings.com -- in case you need to connect to excel 2007
Like so:

Dim ws As Excel.Worksheet
Dim cnn As ADODB.Connection
Dim cmd As ADODB.Command
Dim strQry As String
Dim lngRecsAff As Long

Set cnn = New ADODB.Connection
cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyExcel.xls;Extended Properties="""Excel 8.0;HDR=Yes;IMEX=1""";
cnn.Open

strQry = "INSERT INTO targetrange (Name, Country) SELECT DISTINCT Name, Country FROM sourcerange"

Set cmd = New ADODB.Command
Set cmd.ActiveConnection = cnn
cmd.CommandType = adCmdText
cmd.CommandText = strQry
cmd.Execute lngRecordsAffected
debug.print lngRecordsAffected

I didn't test the code, it's made from parts of a project of mine, so in case you run into any bug and you cant fix it yourself, please come back here and I'll have a look into it.

regards

BManke

[nader]

I don't wnat to use Excel2007 or ADODB I want to make it as it shwo in the pic2 .the first code it success with me but the second it didn't success but I'm sure is possible to do it but I don't know how. I tried many ways but didn't success with me, so I,m asking here.

[BManke]

Well you can use ADODB with any other excel. It's pretty much the most efficient way of doing this. And it's in code, just slap it in a module... Sounded pretty much like your specifications....

If you prefer the other way - I'm sure that's possible too. Just not my way , hope you can figure it out.

regards

BManke

[nader]

I hope to get other way. I don't want this way and thank you for help.

[nader]

Here is the code

Dim myRange3 As Range
Dim R As Long
Dim cell As Range
 
Set myRange3 = Worksheets("sheet2").Range("A1:A100") 'ÇáãÇÏÉ
For Each cell In myRange3
    If IsError(Application.Match(cell.Value, Sheets("sheet3").Columns(1), 0)) _
    Or IsError(Application.Match(cell.Offset(0, 1).Value, Sheets("sheet3").Columns(2), 0)) _
    Or IsError(Application.Match(cell.Offset(0, 2).Value, Sheets("sheet3").Columns(3), 0)) _
    Or IsError(Application.Match(cell.Offset(0, 3).Value, Sheets("sheet3").Columns(4), 0)) Then
        R = Sheets("sheet3").UsedRange.Rows.Count
        If R <> 1 Or Sheets("sheet3").Range("A1").Value <> "" Then R = R + 1
        cell.Resize(, 8).Copy Sheets("sheet3").Range("a" & R)
       
    End If
Next cell