مطلوب كود ترحيل بيانات من اعمدة محددة بناء على شرط فى اكثر من عمور

[ehabaf2]

السلام السادة الافاضل خبراء الموقع المحترم اوفيسنا

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

مرفق الملف المطلوب العمل عليه

الف الف شكرا لحضراتكم

ملف عمليات.xlsx

[abouelhassan]

محتاج شرح بسيط تفصيلي 

الكود يقوم بترحيل الملون بالاصفر إلى اين 

[ehabaf2]

يرحل الى sheet2 يرحل كل البيانات التى ينطبق عليها الشرط بنفس ترتيب الاعمدة الموجود فى sheet 2 

الف الف شكر لمرور حضرتك

 

[abouelhassan]

3 ساعات مضت, ehabaf2 said:

يرحل الى sheet2 يرحل كل البيانات التى ينطبق عليها الشرط بنفس ترتيب الاعمدة الموجود فى sheet 2 

الف الف شكر لمرور حضرتك

 

ماهو الشرط اخى الكريم 

[محمد هشام.]

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

جرب الحلول التالية ربما هدا ما تقصده 

Sub test1()
    Dim crit$, crit2$, F() As String
    Dim rng As Range, lr As Long
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    Dim desWS As Worksheet: Set desWS = Sheets("Sheet2")
    ReDim F(1 To 4)
    'Bill Type Code ******************************************Action Type & Terminal Type
    F(1) = "240": F(2) = "2400": F(3) = "26408": F(4) = "293": crit = "DEB": crit2 = "INT"
    
Application.ScreenUpdating = False
    If WS.AutoFilterMode Then WS.AutoFilterMode = False

With WS.Range("A2:K2")
.AutoFilter 3, F, xlFilterValues: .AutoFilter 4, crit, xlFilterValues: .AutoFilter 11, crit2, xlFilterValues
 lr = WS.Columns("A:A").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Set rng = WS.Range("A3:K" & lr).SpecialCells(xlCellTypeVisible)
        If rng.Cells.Count > 1 Then
        desWS.Range("A2:F" & Rows.Count).Clear
With rng
Cpt = Split("A,B,D,J,G,K", ",") ' الاعمدة المرحلة
Col = Split("A,B,C,D,E,F", ",") 'الاعمدة المرحل اليها
For i = LBound(Cpt) To UBound(Cpt)
WS.Range(Cpt(i) & "2:" & Cpt(i) & lr).Copy desWS.Range(Col(i) & "1")
           Next i
        End With
      End If
  .AutoFilter
  Application.ScreenUpdating = True
End With
End Sub
'''''''''''''''''''''''''''''''''''''''
Sub test2()
Dim a, i&, k&, F$, S$: F = "DEB": S = "INT"
Dim WS As Worksheet: Set WS = Sheets("Sheet1")
Dim desWS As Worksheet: Set desWS = Sheets("Sheet2")
Application.ScreenUpdating = False
desWS.Range("A2:F" & Rows.Count).Clear
a = WS.Range("A2:K" & WS.[A65000].End(xlUp).Row)

For i = 1 To UBound(a)

'Action Type & Terminal Type
If a(i, 4) = F And a(i, 11) = S Then

''Bill Type Code
    If a(i, 3) = "240" Or a(i, 3) = "2400" Or a(i, 3) = "26408" Or a(i, 3) = "293" Then
    
 ' الاعمدة المرحلة
        desWS.Cells(k + 2, 1).Resize(, 6) = Application.IfError(Application.Index(a, i, Array(1, 2, 4, 10, 7, 11)), "")
              k = k + 1
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

 

 

ملف عمليات V1.xlsm

تم تعديل فبراير 14 بواسطه محمد هشام.
Modify column names

[ehabaf2]

السلام عليكم السادة اعضاء الجروب الافاضل

استاذنا الغالى محمد هشام 

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

زادك الله من فضله و علمه و بارك الله فيك و فى اسرتك الكريمة