كود ترحيل بناء علي قائمة منسدلة

[2saad]

إخواني أعضاء المنتدي الكرام بعد سلام الله عليكم ورحمته وبركاته

أتقدم بخالص الشكر لكل الاعضاء لاني تعلمت منهم الكثير في هذا المنتدي الجليل

محتاج كود يقوم بترحيل البيانات من sheet1  و sheet2  و sheet3 الي شيت ( saad ) بناء علي القائمة المنسدلة r12    (  أرجو أن تكون بالمصفوفات )way.xlsm

[ابراهيم الحداد]

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

استخدم الكود التالى

Sub GetData()
Dim Sh As Worksheet, ws As Worksheet
Dim LR As Long, Countr As Long, p As Long
Dim Arr(), Fsl As String, C As Range, j As Long
Set Sh = Sheets("saad")
Sh.Range("C14:T1000") = ""
Fsl = Sh.Range("R12")
For Each ws In Worksheets
If ws.Name <> Sh.Name Then
LR = ws.Range("C" & Rows.Count).End(3).Row
Countr = Countr + LR
End If
Next
ReDim Preserve Arr(Countr, 18)
For Each ws In Worksheets
If ws.Name <> Sh.Name Then
For Each C In ws.Range("C10:C" & LR)
If C.Offset(0, 15).Value = Fsl Then
p = p + 1
For j = 0 To 17
Arr(p - 1, j) = C.Offset(0, j)
Arr(p - 1, 0) = p
Next
End If
Next
End If
Next
If p > 0 Then Sh.Range("C14").Resize(p, UBound(Arr, 2)).Value = Arr
End Sub

 

[2saad]

شكرا جزيلا أستاذ / ابراهيم وجعله الله في ميزان حسناتك

أنا بتعبك معاي كثيرا

لي سؤال من فضلك 

لو فيه شيتات كثيرة في الملف ( اوراق عمل ) وأنا عايز ارحل  sheet1  و sheet2  و sheet3 فقط الي شيت ( saad ) بناء علي القائمة المنسدلة r12

التغيير هيبقي ازاي في الجزئية دي 

If ws.Name <> Sh.Name Then

[2saad]

أرجو الرد من الأخوة الأفاضل

[محمد هشام.]

بعد ادن الاستاد الفاضل  @ابراهيم الحداد

جرب اخي 

Sub GetData()
Dim Sh As Worksheet
Dim WS_Sheets_Name As Variant
Dim LR As Long, Countr As Long, p As Long
Dim Arr(), Fsl As String, C As Range, j As Long
Set Sh = Sheets("saad")
Sh.Range("C14:T1000") = ""
Fsl = Sh.Range("R12")
For Each WS_Sheets In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
LR = WS_Sheets.Range("C" & Rows.Count).End(3).Row
Countr = Countr + LR
Next WS_Sheets
ReDim Preserve Arr(Countr, 18)
For Each WS_Sheets In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
For Each C In WS_Sheets.Range("C10:C" & LR)
If C.Offset(0, 15).Value = Fsl Then
p = p + 1
For j = 0 To 17
Arr(p - 1, j) = C.Offset(0, j)
Arr(p - 1, 0) = p
Next
End If
Next
Next WS_Sheets
If p > 0 Then Sh.Range("C14").Resize(p, UBound(Arr, 2)).Value = Arr
End Sub

 

way 2.xlsm

تم تعديل مايو 22, 2023 بواسطه Mohamed Hicham

[2saad]

شكرا جزيلا للاستاذ ابراهيم والأستاذ محمد وبارك الله فيكما وجعله الله في ميزان حسناتكما

[محمد هشام.]

العفو اخي اليك حل اخر في حالة الرغبة بنسخ البيانات في اخر صف فارغ 

Public Sub transfer_data()   
Dim ws_Data As Worksheet
Dim WS_Sheets_Name As Variant
Dim Rng As Range, LR As Long
Set ws_Data = ThisWorkbook.Worksheets("saad")

Application.ScreenUpdating = False
'ws_Data.Range("c14:t1000").ClearContents

For Each WS_Sheets In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
 Set st = ws_Data.Range("R12")
  With WS_Sheets
    Set Rng = .Range("C9:T" & .Cells(.Rows.Count, "C").End(xlUp).Row)
  End With

  With Rng
    Dim cntCrit As Long
    cntCrit = WorksheetFunction.CountIfs(Rng.Columns(16), st)
    
    If cntCrit <> 0 Then
        .AutoFilter Field:=16, Criteria1:=st
        LR = ws_Data.Range("C" & Rows.Count).End(xlUp).Row + 1
        .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Copy
         ws_Data.Range("C" & LR).PasteSpecial (xlPasteValues)
        
      
    End If
.Parent.AutoFilterMode = False
  End With
     Next WS_Sheets

End Sub

 

way 3.xlsm

[2saad]

الله يبارك فيك شكرا جزيلا

[elmansyeswa]

جعله الله فى ميزان حسناتك