ترحيل بشروط

[الخطيب بيبوو]

 

اولا وليس اخير انت فعلا مبدع جدا

ولذلك استاذنكم فى شئ بسيط لا وهو 

1-ممكن نلغى صفحة التقرير عند فتح الفورم ياخذ مباشر من صفحة الشغل  

2- يتم تحديث الفورم تلقائى مع الشغل الحديث

3- زيادة اضافة sheckbox لرقم العقد

4- عمل كود برمجى من خلاله ارحل كل مقاول او عملية او كلاستر فى صفحة مستقلة 

الاعمال الجنوبية2024 new.xlsm

[محمد هشام.]

هل تقصد انشاء اوراق عمل باسم المقاولين ونسخ بياناتهم ادا كان هدا هو طلبك  

هل سيتم ترحيل  اعمدة معينة  ؟  او ترحيل من A الى O

[محمد هشام.]

تفضل اخي قد تم تنفيد المطلوب على الملف المرفق 

بالنسبة لطلب كود انشاء اوراق  عمل باسماء المقاولين ونسخ بياناتهم يمكنك استخدام الكود التالي والدي قد تمت اظافته مسبقا على الملف مع بعض الاكواد  الاظافية ستجدها داخل الملف يمكنك اختيار ما يناسبك 

Sub CreateSheets()
    Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("الشغل")
    Dim Col As Range, Sh As Collection, rng As Range, arr As Variant
    Dim cell As Range, lr  As Long, ws As Worksheet
    Dim Clé As Variant, s As String, SheetName As String
    
    Set Col = desWS.Range("C5:C" & desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Row)
    Set Sh = New Collection
    
   With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
     Msg = MsgBox(" تحديث العقود " & " " & "؟", vbYesNo, "Admin")
      If Msg <> vbYes Then Exit Sub
    desWS.ListObjects(1).ShowAutoFilter = False
'*********' قم باظافةاسماء اوراق العمل الغير مرغوب حدفها من المصنف هنا**************
SheetName = "الشغل,the report,النسب ,القائمة"
'***********************************************************************************
For Each ws In Worksheets
  If InStr(1, SheetName, ws.Name) = 0 Then
    F = Application.Match(ws.Name, arr, 0)
    If IsError(F) Then
      ws.Delete
    End If
  End If
Next ws
On Error Resume Next
    For Each cell In Col.Cells
    Sh.Add cell.Value, CStr(cell.Value)
  Next cell
On Error GoTo 0
For Each Clé In Sh
    s = Clé
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = Clé
    ActiveSheet.DisplayRightToLeft = True
With desWS.Range("A5:O5")
    .AutoFilter 3, Clé, xlFilterValues
    lr = desWS.Columns("C:C").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Set rng = desWS.Range("A4:O" & lr).SpecialCells(xlCellTypeVisible)
        rng.Copy Sheets(s).Cells(Rows.Count, "A").End(xlUp).Offset(3)
        .AutoFilter
For Each Cpt In Worksheets
  If InStr(1, SheetName, Cpt.Name) = 0 Then
    F = Application.Match(Cpt.Name, arr, 0)
     If IsError(F) Then
     For i = 1 To 15
      Cpt.Columns(i).ColumnWidth = desWS.Columns(i).ColumnWidth
      Cpt.Rows(i).RowHeight = desWS.Rows(i).RowHeight
            Next
        End If
    End If
 Next Cpt
    Sheets(s).Activate
    Cells.Interior.Color = xlNone
    With ActiveWindow
      .SplitColumn = 3: .SplitRow = 0
       ActiveWindow.FreezePanes = True
            End With
         End With
     Next Clé
    desWS.Activate
.ScreenUpdating = True
.DisplayAlerts = True
 End With
   Contractors
End Sub

بالتوفيق ............

 

الاعمال الجنوبية userform 2.xlsm

تم تعديل فبراير 26 بواسطه محمد هشام.

[الخطيب بيبوو]

تسلم ايدك 

تستحق حقا كلمة الاستاذ المحترم محمد هشام

[محمد هشام.]

شكرا لك اخي الكريم يسعدنا اننا استطعنا مساعدتك

بالتوفيق🫡

[الخطيب بيبوو]

كنت عايز اتعلم ويكون ليك الفضل كيف اكون محترف مثلك فى vba

01273263994

ارجوا ارسال رسالة على الواتس لاتمكن من الشكر شخصيا 

 

تم تعديل فبراير 26 بواسطه الخطيب بيبوو