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

[samycalls2020]

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

معى ملف لجلب بيانات بدون فراغات مع الترتيب الأبجد من جدول 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

[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").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

 

تم تعديل ديسمبر 24, 2019 بواسطه samycalls2020

[samycalls2020]

للرفع

[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

 

[samycalls2020]

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

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

 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

 

[samycalls2020]

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

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

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

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

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

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

 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

[samycalls2020]

شكراً استاذنا الكريم/ سليم على وقتك وجهدك .. بارك الله فيك

[samycalls2020]

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

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

 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

[samycalls2020]

جزاك الله خير .. أ/ سليم