اذهب الي المحتوي
أوفيسنا

تعديل لكود جلب أوترحيل بيانات


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

السلام عليكم ..

معى ملف لجلب بيانات بدون فراغات مع الترتيب الأبجد من جدول MM

لكن فى حالة عمل تصفية للجدول MM لأى عمود مثلاً E "الاسم" لأختيار أسماء محدده فى ورقة DATA , وعندجلب الأسماء بالكود فى ورقة AS يجلب ما تم تصفيته .

المطلوب هو أن يقوم الكود بجلب جميع بيانات الجدول كما هو دون النظر الى التصفية .. مع احترامى ..

 

جلب أوترحيل بيانات.rar

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

جرب هذا الكود

Option Explicit

Sub my_code()
  Dim D       As Worksheet, A As Worksheet
  Dim lr      As Long
  Dim RGA     As Range, RgD As Range
  Dim RA      As Long, RD As Long
 
    Set D = Sheets("DATA"): Set RgD = D.Range("B5").CurrentRegion
    Set A = Sheets("AS"): Set RGA = A.Range("B1").CurrentRegion
    RA = RGA.Rows.Count: RD = RgD.Rows.Count
    Set RgD = RgD.Offset(2).Resize(RD - 2)
    Set RGA = RGA.Offset(2).Resize(RA - 2)
     RGA.Clear
     A.Range("B3").Resize(RgD.Rows.Count, RgD.Columns.Count).Value = _
     RgD.Value
A.Range("B1").CurrentRegion.Borders.LineStyle = 1
End Sub

 

Tarhil.xlsb

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

الأستاذ الكبير / سليم

كل الشكر على المشاركة 

الكود يعمل ولكن ينقل البيانات بالفراغات وبدون ترتيب ..

فهل من الممكن التعديل على الكود الأساسى 

 

 Sub Test3()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim lr          As Long
    Set ws = Sheets("DATA")
    Set sh = Sheets("AS")
      Application.ScreenUpdating = False
        sh.Range("B3:U1026").ClearContents
        lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 2
        ws.Range("B7:U1026").SpecialCells(xlCellTypeVisible).Copy
        sh.Range("B" & lr).PasteSpecial xlPasteValues
   LRR = sh.Cells(Rows.Count, 4).End(xlUp).Row + 1
   sh.Range("B3:U" & LRR).Sort Key1:=sh.Range("E3"), Order1:=xlAscending
        On Error Resume Next
            sh.Columns(5).Replace 0, ""
            sh.Columns(5).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        On Error GoTo 0
        Application.CutCopyMode = False
    Application.ScreenUpdating = False
     'ÊÓØíÑ ÌÏæá ÇáÈíÇäÇÊ ÇáÊí Êã ÌáÈåÇ
   Range("B3").CurrentRegion.Borders.Value = 1
End Sub

 

تم تعديل بواسطه samycalls2020
رابط هذا التعليق
شارك

فى محاولة للحل أتت بنتيجة

  Sub Test3()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim lr          As Long
    Set ws = Sheets("DATA")
    Set sh = Sheets("AS")
      Application.ScreenUpdating = False
        sh.Range("B3:U1026").ClearContents
        lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 2
        ws.Range("B7:U1026").Copy
        sh.Range("B" & lr).PasteSpecial xlPasteValues
   LRR = sh.Cells(Rows.Count, 4).End(xlUp).Row + 1
   sh.Range("B3:U" & LRR).Sort Key1:=sh.Range("E3"), Order1:=xlAscending
        On Error Resume Next
            sh.Columns(5).Replace 0, ""
            sh.Columns(5).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        On Error GoTo 0
        Application.CutCopyMode = False
    Application.ScreenUpdating = False
     'ÊÓØíÑ ÌÏæá ÇáÈíÇäÇÊ ÇáÊí Êã ÌáÈåÇ
   Range("B3").CurrentRegion.Borders.Value = 1
End Sub

 

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

جزء أخر أرجو المساعده فيه

الترتيب يتم عن طريق 

 sh.Range("B3:U" & LRR).Sort Key1:=sh.Range("E3"), Order1:=xlAscending

E3 أى عمود E  ويمكن تغيره فى الكود الى G3 أو غير ذلك .. فهل من الممكن عمل عمل قائمة منسدلة فى A1 مثلاُ ويتم اختيار عمود الفرز منها

 

جلب أوترحيل بيانات2.rar

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

المشكلة عندك ان بعض الصفوف تأخذ قيمة الصفر  بسبب المعادلات

عندها لا يعتتبرها اكسل فارغة

جرب هذا الماكرو

Option Explicit

Sub my_code()
  Dim D       As Worksheet, A As Worksheet
  Dim RGA     As Range, RgD As Range
  Dim RA      As Long, RD As Long
  Dim obj As Object, i%
  Dim m%, n%: n = 19
  Dim k%: k = 0
  Dim X
  Set D = Sheets("DATA"): Set A = Sheets("AS")
 Dim My_max: My_max = D.Cells(5, 3).CurrentRegion.Rows.Count + 4
Set obj = CreateObject("Scripting.Dictionary")
Dim arr
For i = 7 To My_max
  If Application.CountA(D.Range("C" & i).Resize(, n)) = n Then
    arr = Join(Application.Transpose(Application.Transpose(D.Range("c" & i).Resize(, n))), "*")
   obj.Add (k), arr
    k = k + 1
  End If
Next

A.Range("B3").Resize(10000, 25).ClearContents

For m = 1 To obj.Count

A.Cells(m + 2, 2).Resize(1, n) = Split(obj.Item(m - 1), "*")
Next

End Sub



 

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

أخى الأستاذ / سليم 

شكراً على مجهودك الكبير .. الكود به نفس المشاكل ينقل البيانات بالفراغات ( القيم الصفرية الناتجه من المعادلات ) وبدون ترتيب ..

أنا قمت بمحاولة للحل أتت بنتيجة وهى موجوده بالمشاركات السابقة بأعلى ..

وطلبى الأن أن سمحت لى هو 

وأرجو المساعده فيه

الترتيب يتم عن طريق 

 sh.Range("B3:U" & LRR).Sort Key1:=sh.Range("E3"), Order1:=xlAscending

E3 أى عمود E  ويمكن تغيره فى الكود الى G3 أو غير ذلك .. فهل من الممكن عمل عمل قائمة منسدلة فى A1 مثلاُ ويتم اختيار عمود الفرز منها

جلب أوترحيل بيانات2.rar

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

للعمل بالكود يجب ام يكون الجدول مستقلاً (راس واحد دون تدخل خلايا غير فارغة على كل اطرافه)

تم التعديل على تصميم الجدول في الصفحة AS بحيث يفهمه اكسل كجدول حقيقي 

الكود بعد تعديله 

  Sub MY_Test()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim lr          As Long
    Set ws = Sheets("DATA")
    Set sh = Sheets("AS")
   
  With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = True
  End With
      
     On Error Resume Next
           With sh
             .Range("B2:U1026").Clear
              ws.Range("B7:U1026").Copy
             .Range("B2").PasteSpecial xlPasteValues
             .Columns(5).Replace 0, ""
             .Columns(5).SpecialCells(4).EntireRow.Delete
             .Range("B1").CurrentRegion.Sort _
             Key1:=sh.Range("E1"), Order1:=1, Header:=1
             .Range("M:L").NumberFormat = "d/m/yyyy"
          End With
    On Error GoTo 0
  
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
  End With
   Range("B3").CurrentRegion.Borders.Value = 1
   Range("B3").CurrentRegion.Offset(1).InsertIndent 1
   sh.Range("B1").Select
End Sub

   


الملف مرفق

 

Extract_sans_vide.xlsb

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

جزء أخر أرجو المساعده فيه

الترتيب يتم عن طريق 

 sh.Range("B3:U" & LRR).Sort Key1:=sh.Range("E3"), Order1:=xlAscending

E3 أى عمود E  ويمكن تغيره فى الكود الى G3 أو غير ذلك .. فهل من الممكن عمل عمل قائمة منسدلة فى A1 مثلاُ ويتم اختيار عمود الفرز منها

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

  • أفضل إجابة

يمكن ذلك

لكن عليك وضع القائمة المنسدلة بعيداً عن الجدول (العامود A  والعامود V   لا يصلحان لانهما ملاصقان للجدول  انا اخترت العامود  X )

كما ذكرت لك ( دون تدخل خلايا غير فارغة على كل حدود الجدول)

الماكرو:

  Sub MY_Test_CHOOS_FILTER()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim lr          As Long
    Set ws = Sheets("DATA")
    Set sh = Sheets("AS")
   
  With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = True
  End With
      
     On Error Resume Next
           With sh
             .Range("B2:U1026").Clear
              ws.Range("B7:U1026").Copy
             .Range("B2").PasteSpecial xlPasteValues
             .Columns(5).Replace 0, ""
             .Columns(5).SpecialCells(4).EntireRow.Delete
             .Range("B1").CurrentRegion.Sort _
             Key1:=sh.Range(Range("X1")), Order1:=1, Header:=1
             .Range("M:L").NumberFormat = "d/m/yyyy"
          End With
    On Error GoTo 0
  
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
  End With
   Range("B3").CurrentRegion.Borders.Value = 1
   Range("B3").CurrentRegion.Offset(1).InsertIndent 1
   sh.Range("B1").Select
End Sub

   



الملف مرفق

Extract_WITH_CHOOSEN_FILTER.xlsb

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information