مساعدة في نقل بيانات بدون تكرار

[hassan rady]

السلام عليكم ورحمة الله وبركاته
اخوتي الاعزاء هل اجد لديكم حل لمشكلتي
لدي عمود به ارقام مكررة وهذه الارقام تختلف كل شهر ربما تزيد وربما تقل
اريد ان ارحل البيانات من الشيت الاول الى الشيت الثاني بمعادلة غير معادلات الصفيف لانها ثقيلة 
مرفق لكم مثال

ارقام.rar

[ابراهيم الحداد]

السلام عليكم ورحمة الله

استخدم الكود التالى فهو اخف واسرع

Sub TransNum()
Dim  LR As Long, R As Long, p As Long, x As Integer
LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
For R = 2 To LR
x = WorksheetFunction.CountIf(Sheet1.Range("$A$2:A" & R), Sheet1.Range("A" & R))
If x = 1 Then
p = p + 1
Sheet2.Cells(p + 1, 1) = Sheet1.Cells(R, 1)
End If
Next
End Sub

 

[hassan rady]

استاذي العزيز شكرا على الرد انا كنت عامل كده بالضبط بس ده يحتاج اضيف زر انا عايز لو في معادلة تكون خفيفة وتعمل اوتوماتك

[عبدالسلام ابوالعوافي]

وعليكم السلام 

من عيوب الاكسل البطئ عندما تكون البيانات كبيرة .. ومن الطرق المفيدة في هذه الحالة هي استخدام لغة سيكول 

اليك الكود الاتي ليقوم بالترحيل بسرعة اكبر من المعادلات .. المثال في المرفق

ملاحظة .. تمت التجربة علي اوفس 2013 وقد يحتاج الي تعديل مع النسخ الاخري

Sub InQuery()
Dim intLastR As Double
Dim strSQL
Dim Conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim srtPath As String, strConn As String
    With Application
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    intLastR = ActiveSheet.UsedRange.Rows.Count
    Sheets("Sheet2").Columns(1).ClearContents
    srtPath = ThisWorkbook.FullName
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=" & srtPath & ";" & _
              "Extended Properties=""Excel 12.0 Macro;HDR=Yes;IMEX=1"";"
    intLastR = Sheets("Sheet1").UsedRange.Rows.Count
    Conn.Open strConn
    
    strSQL = "SELECT * From [Sheet1$A1:b" & intLastR & "] WHERE [Column1] = 1"
    
  Debug.Print strSQL
  Debug.Print Conn
    rs.Open strSQL, Conn
    
    Sheet2.Range("A2").CopyFromRecordset rs
    Sheet2.Columns(2).ClearContents
    
    rs.Close
    Conn.Close
    With Application
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

End Sub

 

ارقام.rar

[ياسر خليل أبو البراء]

وعليكم السلام

الموضوع خضني لما بصيت في الأكواد .. لكن لما شفت الملف المرفق .. جه في بالي إن الموضوع من غير أكواد ولا معادلات ولا أعمدة مساعدة ..

ممكن ببساطة ننسخ العمود الأول في ورقة العمل الأولى ونلصقه في الورقة التانية ، ونعمل Remove Duplicates (موجودة في التبويب Data) .. وبس خلاص

 

بس للأمانة أعجبني جداً كود أخي عبد السلام لأنه يتطرق لموضوع غاية في الأهمية وهو استخدام الـ SQL Connection أو ما يعرف بـ ADO

[hassan rady]

كل الشكر لكم احبتي ^__^

[ناصر سعيد]

منذ ساعه, زيزو العجوز said:

السلام عليكم ورحمة الله

استخدم الكود التالى فهو اخف واسرع

Sub TransNum()
Dim  LR As Long, R As Long, p As Long, x As Integer
LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
For R = 2 To LR
x = WorksheetFunction.CountIf(Sheet1.Range("$A$2:A" & R), Sheet1.Range("A" & R))
If x = 1 Then
p = p + 1
Sheet2.Cells(p + 1, 1) = Sheet1.Cells(R, 1)
End If
Next
End Sub

 

ربنا يبارك فيكم يارب الاستاذ زيزو والاستاذ عبد السلام

لو تكرمت اريد شرح للكود وعايز سطر لمسح العمود المنقول اليه اولا

بس للأمانة أعجبني جداً كود أخي عبد السلام لأنه يتطرق لموضوع غاية في الأهمية وهو استخدام الـ SQL Connection أو ما يعرف بـ ADO

جزاك الله خيرا استاذ ياسر والاستاذ عبد السلام

هل يمكن القاء مزيد من الضوء على هذا الموضوع

[سليم حاصبيا]

بعد اذن اساتذتنا الكرام

هذا الكود اسرع قليلاً و اخف وزناً

Sub Salim()
   Sheets("sheet2").Range("a:a").Clear
    Range("Table1[[#All],[NUMBER]]").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Range("Table1[[#All],[NUMBER]]").SpecialCells(12).Copy Sheets("Sheet2").Range("A1")
    Application.CutCopyMode = False
    Sheets("Sheet1").ShowAllData
 End Sub

 

[ناصر سعيد]

6 ساعات مضت, سليم حاصبيا said:

Range("Table1[[#All],

مافائده رمز الشباك جزاكم الله خيرا ؟