ترحيل من شيت لاخر

[Armia Nabil]

السلام عليكم

محتاج كود VBA يرحل من شيت رقم 1 الي شيت التقرير بناءا علي عمود رقم السيارة

وشكرا

تقرير.xlsx

[محمد هشام.]

المرجوا توضيح طلبك اكثر او ارفاق عينة للنتائج المتوقعة 

[Armia Nabil]

مرفق اليك مثال وشكرا للاهتمام

تقرير.xlsx

[Armia Nabil]

طلب مساعده 

[محمد هشام.]

أخي @Armia Nabilرقم السيارة مكرر على طول العمود مثلا الرقم 125 هل يحب ترحيل البيانات على جميع الصفوف ام فقط الصف الأول 

تفضل اختار ما يناسبك 

Option Explicit
Sub test1()
  Dim WS As Worksheet, dest As Worksheet
  Dim c As Range, f As Range
  Set WS = Sheets("1"): Set dest = Sheets("التقرير")
  
  Application.ScreenUpdating = False
  For Each c In WS.Range("H2", WS.Range("H" & Rows.Count).End(3))
    Set f = dest.Range("H:H").Find((c.Value), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      dest.Range("A" & f.Row & ":j" & f.Row).Value = WS.Range("A" & c.Row & ":j" & c.Row).Value
    End If
  Next
  Application.ScreenUpdating = True
End Sub
'========================
Sub test2()
    Dim WS As Worksheet, dest As Worksheet
    Dim Lastrow As Long, i As Long, rng As Range, code As Variant
    Set WS = Sheets("1"): Set dest = Sheets("التقرير")
    Lastrow = WS.Cells(WS.Rows.Count, "H").End(xlUp).Row
    
    Application.ScreenUpdating = False
    With dest
        Intersect(.Range(.Rows(2), .UsedRange.Rows(.UsedRange.Rows.Count)), Union(Range("A:G"), .Range("I:J"))).ClearContents
    End With
    For i = 2 To Lastrow:  code = WS.Cells(i, "H").Value
         Set rng = dest.Columns("H").Find(What:=code, LookIn:=xlValues, LookAt:=xlWhole)
            If Not rng Is Nothing Then
              dest.Cells(rng.Row, "A").Resize(1, 10).Value = WS.Cells(i, "A").Resize(1, 10).Value
            End If
        Next i
    Application.ScreenUpdating = True
End Sub
'=================================
Sub test3()
Dim WS As Worksheet, dest As Worksheet
Dim cel As Range, r As Range, tmp As Range
Set WS = Sheets("1"): Set dest = Sheets("التقرير")

Application.ScreenUpdating = False
    For Each tmp In dest.Range("H2:H" & dest.Cells(Application.Rows.Count, 8).End(xlUp).Row)
        Set r = WS.Columns(8).Find(tmp.Value, , xlValues, xlPart)
        If Not r Is Nothing Then
        dest.Range("A" & tmp.Row & ":j" & tmp.Row).Value = WS.Range("A" & r.Row & ":j" & r.Row).Value
        End If
    Next tmp
Application.ScreenUpdating = True
End Sub

 

تقرير.xlsb

تم تعديل يوليو 24 بواسطه محمد هشام.

[طارق محمود]

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

تفضل

تقرير.xlsx

[Armia Nabil]

أ/ محمد هشام

تحية طيبة 

مرسل مثال المقصود او المطلوب من زيادة عدد الصفوف في شيت التقرير هو ترحيل كل ما يخص السيارة من شيت رقم 1 الي شيت التقرير بمعني كل ما اضيف بيانات في شيت رقم 1 تخص اي رقم سيارة من السيارات ترحل الي الصفوف الخاصة بها في شيت التقرير 

علما بان شيت رقم 1 لا يقتصر علي البيانات المرسلة فقط ولكن سيضاف بيانات اكثر او صفوف اكثر في شيت 1 والمراد ترحيلها لشيت التقرير ويضاف ايضا اكثر من سيارة 

وشكرا

تقرير.xlsx

حضرتك في المثال اللي بعته بيرحل صف واحد بنفس البيانات في جميع صفوف السيارة انا اللي عايزه ان اي صف اضيف للسيارة مثلا 125 في شيت 1 يرحل لشيت التقرير في صف اخر اي اي بيانات تخص السيارة 125 في صفحة 1 ترحل لشيت التقريرتقرير.xlsx

بعد اذنك كمان انا محتاج علامة الترحيل تكون موجودة في شيت رقم 1 مش في شيت التقرير

[Armia Nabil]

أ/ محمد هشام

تحية طيبة وبعد

برجاء الافادة شاكرين حسن تعاونكم

 

[محمد هشام.]

نعم اخي لاكن ما الغرض من تسلسل رقم السيارة على ورقة التقرير يمكنك نسخ البيانات دون الاعتماد على وجود رقم السيارة مسبقا

في حالتك هده يمكنك الاعتماد على عدد الصفوف لكل جدول والتي سوف تجبرك على  توحيد عدد الصفوف على جميع الجداول

مادا لم تمت اظافة رقم السيارة بعدد يتجاوز عدد الصفوف المقترحة مسبقا  وهي على ملفك 60 صف ؟ 

 على العموم  تم تعديل الكود على حسب تصميمك للملف ربما يناسبك 

Option Explicit
Sub Filter_ListUniques()
Dim WS As Worksheet: Dim src As Worksheet
Set WS = Worksheets("1"): Set src = Worksheets("التقرير")
    Dim Lastrow&, f&, n&
    Dim list As Object, item As Variant, Rng As Range, tmp As Range
    Set list = CreateObject("System.Collections.ArrayList")
    
Application.ScreenUpdating = False
Intersect(src.Range(src.Rows(2), src.UsedRange.Rows(src.UsedRange.Rows.Count)), _
                      Union(src.Range("A:G"), src.Range("I:J"))).ClearContents
Set tmp = WS.Range("A1:J1")
With WS
 If .AutoFilterMode Then .AutoFilterMode = False
        For Each item In .Range("H2", .Range("H" & .Rows.Count).End(xlUp))
            If Not list.Contains(item.Value) Then list.Add item.Value
        Next
     End With
     
For Each item In list
     With tmp
           .AutoFilter 8, item '<<======Car number column
           
Lastrow = WS.Cells(WS.Rows.Count, "H").End(xlUp).Row
WS.Range("a2:j" & Lastrow).SpecialCells(xlCellTypeVisible).Copy
 If WorksheetFunction.CountA(src.Range("a:a")) = 1 Then
       n = src.Cells(src.Rows.Count, "a").End(xlUp).Row + 1
 Else
 'The number of rows between tables
 n = n + 61
  End If
src.Range("a" & n).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
'Copy column headings
  src.Range("a" & n - 1 & ":j" & n - 1).Value = tmp.Value
       .AutoFilter
      End With
    Next
   Application.ScreenUpdating = True
End Sub

 

 

تقرير V2.xlsb

[Armia Nabil]

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

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

[محمد هشام.]

13 ساعات مضت, Armia Nabil said:

اني غير مرتبط بعدد صفوف معينة فهي قابلة للزيادة او النقصان

ادن جرب هدا 

Option Explicit
Sub Filter_ListUniques()
Dim lastRow&, n&, F&
Dim WS As Worksheet, src As Worksheet, _
tmp As Range, rngCell As Range, c As Range, _
rng As Range, r As Range, list As Range

Set WS = Worksheets("1"): Set src = Worksheets("التقرير")

With Application
.ScreenUpdating = False

With WS
 If .AutoFilterMode Then .AutoFilterMode = False
       lastRow = WS.Cells(WS.Rows.Count, "H").End(xlUp).Row
       Set rng = WS.Range("A1:J" & lastRow)
 Intersect(src.Range(src.Rows(1), _
    src.UsedRange.Rows(src.UsedRange.Rows.Count)), src.Range("A:J")).Clear
.Range("H1:H" & lastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range("AA1"), Unique:=True
Set list = .Range(.[AA2], .Cells(.Rows.Count, "AA").End(xlUp))

For Each tmp In list
  rng.AutoFilter 8, tmp.Value
     n = src.Range("A" & src.Rows.Count).End(xlUp).Row
       If n > 2 Then n = n + 2
           rng.SpecialCells(xlCellTypeVisible).Copy
              src.Range("a" & _
              n).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
           Next tmp
       WS.AutoFilterMode = False
    End With
On Error Resume Next
F = src.Range("A:J").Find("*", SearchOrder:=xlByRows, _
                     SearchDirection:=xlPrevious).Row
Set rngCell = src.Range("A1 :J" & F)
   For Each c In rngCell.Rows
   If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous
    Next
For Each r In src.Range("A1:A" & F)
 If r.Value = "سعر الوقود" Then
    With src.Range(src.Cells(r.Row, 1), src.Cells(r.Row, 10))
           .Interior.Color = RGB(51, 204, 204)
           .Font.Bold = True
     End With
 End If
Next
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub

 

 

 

تقرير 3.xlsm

[Armia Nabil]

شكرا جدا مستر محمد