اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by عبدالسلام ابوالعوافي,

الردود الموصى بها

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

ارقام.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

 

  • Like 1
رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

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

ملاحظة .. تمت التجربة علي اوفس 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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

 

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

رابط هذا التعليق
شارك

منذ ساعه, زيزو العجوز 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

 

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information