اريد ترحيل الى الصفحات من اليومية

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

يوجد شيت يوميةالزرع.xlsm اريدالترحيل البيانات الى الصفحات بناء على العمود بناءا على كود سابق من استذة المنتدى اريد تكملة الترحيل من العمود (g --h)

[محمد هشام.]

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

Option Explicit
Sub test()
    Dim a As Variant, headers As Variant, result As Variant, dic As Object, WS As Worksheet, dest As Worksheet
    Dim i As Long, j As Long, s As String, rowCount As Long, k As Long, lastRow As Long, rng As Range, c As Range
    
    Set WS = Sheets("يومية المقاولين")
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    
    With WS
        a = .Range("E7:M" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value
        headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", "الفارغ", "الصافي", "السعر", "القيمة")
    End With

    For i = 1 To UBound(a, 1)
        s = Trim(CStr(a(i, 3)))
        If Len(s) > 0 And Not dic.exists(s) Then
            dic(s) = Empty
            s = Replace(s, "/", "_"): s = Replace(s, "\", "_")
            On Error Resume Next
            Set dest = Sheets(s)
            On Error GoTo 0

            If dest Is Nothing Then
                Set dest = Sheets.Add(, Sheets(Sheets.Count))
                dest.Name = s
                dest.DisplayRightToLeft = True
            Else
                dest.Range("A9:J" & dest.Rows.Count).Clear
            End If

            With dest.Range("A9:J9")
                .Value = headers
                .Font.Bold = True
                .Interior.Color = RGB(204, 255, 255)
            End With

            rowCount = 0
            For j = 1 To UBound(a, 1)
                If Trim(CStr(a(j, 3))) = s Then rowCount = rowCount + 1
            Next j

            ReDim result(1 To rowCount, 1 To UBound(a, 2))
            rowCount = 1
            For j = 1 To UBound(a, 1)
                If Trim(CStr(a(j, 3))) = s Then
                    For k = 1 To UBound(a, 2)
                        result(rowCount, k) = a(j, k)
                    Next k
                    rowCount = rowCount + 1
                End If
            Next j

            dest.Range("B10").Resize(UBound(result, 1), UBound(result, 2)).Value = result
            With dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row)
                .Value = Evaluate("ROW(" & .Address & ")-9")
            End With

            On Error Resume Next
            lastRow = dest.Columns("A:J").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
            On Error GoTo 0
            If lastRow = 0 Then lastRow = 9

            Set rng = dest.Range("A9:J" & lastRow)
            With rng
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Borders.LineStyle = xlNone
                .ColumnWidth = 10
            End With

            For Each c In rng.Rows
                If Application.WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous
            Next c
        End If
        Set dest = Nothing
    Next i

    WS.Activate
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

الزرع v2.xlsm

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

تسلم ايدك على الكود 

لكن اريد زيادة على هذا 

الى حضرتك عملته تزيد عليه  فتح شيتات عن طريق العمود h "الصنف " ايضا 

[محمد هشام.]

تفضل أخي 

Option Explicit
Sub test()
 Dim i, j, tbl, k, lastRow As Long, rng As Range, c As Range, s As String
 Dim dic As Object, WS As Worksheet, dest As Worksheet
 Dim a, headers, result, colArr, tmp As Variant
  
    Set WS = Sheets("يومية المقاولين")
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
   
    Set dic = CreateObject("Scripting.Dictionary")

    With WS
        a = .Range("E7:M" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value
        headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", _
                                         "الفارغ", "الصافي", "السعر", "القيمة")
    End With
    colArr = Array(3, 4) ' المورد (G) و الصنف (H)
    For Each tmp In colArr
        dic.RemoveAll
        For i = 1 To UBound(a, 1)
            s = Trim(CStr(a(i, tmp)))
            If Len(s) > 0 And Not dic.exists(s) Then
                dic(s) = Empty
                s = Replace(s, "/", "_"): s = Replace(s, "\", "_")
                On Error Resume Next
                Set dest = Sheets(s)
                On Error GoTo 0

                If dest Is Nothing Then
                    Set dest = Sheets.Add(, Sheets(Sheets.Count))
                    dest.Name = s
                    dest.DisplayRightToLeft = True
                    dest.Rows("9").RowHeight = 20
                Else
                    dest.Range("A9:J" & dest.Rows.Count).Clear
                End If

                With dest.Range("A9:J9")
                    .Value = headers: .Font.Bold = True: .Interior.Color = RGB(204, 255, 255)
                End With

                tbl = 0
                For j = 1 To UBound(a, 1)
                    If Trim(CStr(a(j, tmp))) = s Then tbl = tbl + 1
                Next j

                ReDim result(1 To tbl, 1 To UBound(a, 2))
                tbl = 1
                For j = 1 To UBound(a, 1)
                    If Trim(CStr(a(j, tmp))) = s Then
                        For k = 1 To UBound(a, 2)
                            result(tbl, k) = a(j, k)
                        Next k
                        tbl = tbl + 1
                    End If
                Next j

        dest.Range("B10").Resize(UBound(result, 1), UBound(result, 2)).Value = result
        dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row).Value = _
        Evaluate("ROW(" & dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row).Address & ")-9")

        On Error Resume Next
        lastRow = dest.Columns("A:J").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        On Error GoTo 0
        If lastRow = 0 Then lastRow = 9

        Set rng = dest.Range("A9:J" & lastRow)
        With rng
            .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
            .Borders.LineStyle = xlNone: .ColumnWidth = 10
        End With

            For Each c In rng.Rows
                If Application.WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous
            Next c
        End If
        
           Set dest = Nothing
         Next i
     Next tmp

    WS.Activate
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

الزرع v3.xlsm

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

تسلم ايدك لكن لما ازود اعمدة لا ترحل فى الورق الاخر

 

الزرع v3.xlsm

[محمد هشام.]

يجب أخي تعديل النطاق المرغوب داخل الكود مثلا 

 With WS
' نطاق البيانات
            a = .Range("E7:O" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value
' عناوين رؤوس الأعمدة  
            headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", "الفارغ", _
                            "الصافي", "السعر", "القيمة", "متوسط سعر البرنيكة", "متوسط وزن البرنيكة")
    End With

النطاق الهدف 

 On Error Resume Next
        lastRow = dest.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        On Error GoTo 0
        If lastRow = 0 Then lastRow = 9

        Set rng = dest.Range("A9:L" & lastRow)

 

الزرع v4.xlsm

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

الاخ المحترم ممكن تعملها مصفوفةعلشان لخبطت معايا فبها

[محمد هشام.]

أعتقد أن الكود سهل في التعديل خاصة بعدما تم توضيح النقط المهمة لدالك 

صراحة لا أعلم ما تحاول فعله لاكن يمكنك جعل الكود مرن بدون تقييد للنطاقات إدا كنت بحاجة دائمة لإظافة أعمدة جديدة بحيث يمكنك تحديد أول عمود فقط داخل الكود وترك أخر عمود للبيانات تلقائي بحسب الأعمدة المتاحة لديك 

  startRow = 7  '   أول صف للبيانات
    headerRow = 6  ' رقم صف عناوين رؤوس الأعمدة
    startCol = 5  ' أول عمود للبيانات المنسوخة
    ' العثور على اخر عمود
    endCol = WS.Cells.Find(what:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
    With WS
        endRow = .Cells(.Rows.Count, startCol).End(xlUp).Row
        a = .Range(.Cells(startRow, startCol), .Cells(endRow, endCol)).Value
    End With

    Dim h As Variant
    ReDim headers(1 To UBound(a, 2))
    h = WS.Range(WS.Cells(headerRow, startCol), WS.Cells(headerRow, endCol)).Value
    For i = 1 To UBound(a, 2)
        headers(i) = h(1, i)
    Next i

    colArr = Array(3, 4) ' المورد (G) والصنف (H)
    

 

الزرع v5.xlsm

تم تعديل الإثنين at 18:26 بواسطه محمد هشام.

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

تسلم ايدك