مشكلة ترحيل البيانات على نفس الخلايا

[البروفسير]

السلام عليكم
لدي ملف به عدد من الصفحات اريد تجميع خلايا معينة من الصفحات الاولى  ونسخها الى شيت ( مصروفات السيارات )
وجدت الكود ده فعلا كود رائع واعطانى تحكم عالي جدا فى نقل ما اريد من الصفحات .
المشكلة فيه انه ينسخ البيانات من اي صفحة  على نفس خلايا صفحة ( مصروفات السيارات ) كل مرة ...
حاولت استخدم كود

.End(xlUp).Row

بدون فائدة

ده الكود ومحتاج انه ينسخ البيانات بدون ما يضعها على بعض .. فهل من حل ؟؟

Sub aaa()
On Error Resume Next
Dim ws As Worksheet

For Each ws In Worksheets
If ws.Name <> "مصروفات السيارات" And ws.Name <> "كشف حساب" And ws.Name <> "تقارير" Then

 Iarr = Array("H14", "c18", "B21", "B22", "B23", "B24", "B25", "E21", "E22", "E23", "E24", "E25", "E27", "F21", "F22", "F22", "F23", "F24", "F25", "C30", "B31", "B32", "B33", "B34", "C32", "C33", "C34", "D32", "D33", "D34", "B35", "B35", "C35", "D35", "I37", "B61", "H31", "b27")
 Oarr = Array("f2", "c3", "B4", "B5", "B6", "B7", "B8", "c4", "c5", "c6", "c7", "c8", "c10", "d4", "d5", "d5", "d6", "d7", "d8", "C13", "B14", "B15", "B16", "B17", "C15", "C16", "C17", "D15", "D16", "D17", "B18", "B18", "C18", "D18", "I20", "B44", "H14", "b20")
 For i = LBound(Iarr) To UBound(Iarr)
 
 Sheets("مصروفات السيارات").Range(Oarr(i)).Value = Worksheets(ws.Name).Range(Iarr(i))


 Next i

 End If
 Next ws
End Sub

 

[البروفسير]

عايز تعديل بسيط فى الكود .. لو امكن .. عارف ومقدر انكم مشغولين .. بس برجاء الاهتمام .. السلام عليكم

[الـعيدروس]

الاخ الفاضل البروفسير

اعلم ان التعديل على كود جهد مضاعف من انشاء كود 

فما بالك تعديل وبدون ملف يشرح ماتريد

فاارجو منك ارفاق ملف وشرح مبسط لما تريده 

كي تتيح لمن اراد المشاركه تتبع عمل الكود والتعديل عليه 

لما يتناسب مع ملفك او عمل كود اخر يفي بالغرض

السموحه على الاطاله 

تحياتي

[البروفسير]

تم صنع ملف كمثال من اصل 31 يوم تم المثال على 5 ايام فقط
لسهولة التعامل والرفع
 

9-2013.rar

[الـعيدروس]

اذا كنت تريد ترحيل اوراق الايام الى ورقة  "مصروفات السيارات"

 

إستخدم الكود التالي

Private Const Nm As String = "مصروفات السيارات"
Public N_Sh$
Public Sub Ali_Tr()
Dim Sh As Worksheet, S As Worksheet
Dim my_r As Range
Dim Lr&
Set S = Sheets(Nm)
S.Cells.Clear
For Each Sh In ThisWorkbook.Worksheets
With Sh
Select Case .Name
       Case Is = Nm, "كشف حساب", "تقارير"
       Case Else
       N_Sh = .Name
       Lr = S.Cells(S.Rows.Count, 2).End(xlUp).Offset(1, 0).Row
         .Range("B14:J104").Copy
         Set Rr = S.Range("B" & Lr + 1)
         With Rr
          .Offset(0, -1) = N_Sh
          .PasteSpecial xlPasteValues
         End With
        With S.Range(S.Cells(Rr.Row, 1), S.Cells(Rr.Row, 10))
         .Cells(1, 3) = Application.Text(.Cells(1, 3).Text, "[$-C01]dddd")
         .Cells(1, 8) = Application.Text(.Cells(1, 8).Text, "yyyy/mm/dd")
         .Cells(1, 8).Columns.AutoFit
         .Font.Color = RGB(255, 0, 0)
         .Font.Bold = True
         .Borders.Color = 1
         
        End With
End Select
End With
Next
End Sub

[البروفسير]

 

اذا كنت تريد ترحيل اوراق الايام الى ورقة  "مصروفات السيارات"

 

إستخدم الكود التالي

Private Const Nm As String = "مصروفات السيارات"
Public N_Sh$
Public Sub Ali_Tr()
Dim Sh As Worksheet, S As Worksheet
Dim my_r As Range
Dim Lr&
Set S = Sheets(Nm)
S.Cells.Clear
For Each Sh In ThisWorkbook.Worksheets
With Sh
Select Case .Name
       Case Is = Nm, "كشف حساب", "تقارير"
       Case Else
       N_Sh = .Name
       Lr = S.Cells(S.Rows.Count, 2).End(xlUp).Offset(1, 0).Row
         .Range("B14:J104").Copy
         Set Rr = S.Range("B" & Lr + 1)
         With Rr
          .Offset(0, -1) = N_Sh
          .PasteSpecial xlPasteValues
         End With
        With S.Range(S.Cells(Rr.Row, 1), S.Cells(Rr.Row, 10))
         .Cells(1, 3) = Application.Text(.Cells(1, 3).Text, "[$-C01]dddd")
         .Cells(1, 8) = Application.Text(.Cells(1, 8).Text, "yyyy/mm/dd")
         .Cells(1, 8).Columns.AutoFit
         .Font.Color = RGB(255, 0, 0)
         .Font.Bold = True
         .Borders.Color = 1
         
        End With
End Select
End With
Next
End Sub

 

اخي عباد بالفعل اريد ترحيل الصفحات ولكن ليس كلها ..

اريد مصروفات السيارات الموجود تحت بند سيارة فى الصفحات , والمصروفات الموجودة تحت قسم (  المصروفات الاخري للسيارات ) فقط  ..

حيث ان باقى المعلومات الخاصة بالاكرامية والتوريديات وغيرها غير لا زمة وايضا الهدف هو اخفائها . لان الورقة تطبع لمسؤول الصيانة . ولا يجب ان يعرف كم ورد المندوب وهكذا .

حاولت تجربة كودك الخاص .. ولكن للاسف لم يكتمل .. خطأ فى  [        Set S = Sheets(Nm)        ]   

[الـعيدروس]

اتمنى ان اكون فهمت طلبك بالشكل الصحيح

جرب هذا التعديل

حسب شروطك طال الكود حبتين

Private Const Nm As String = "مصروفات السيارات"
Public N_Sh$
Public Sub Ali_Tr()
Dim Sh As Worksheet
Dim S As Worksheet
Dim My_r As Range
Dim Lr&
Dim My_mx() As Variant
Dim Ar_mx() As Variant
Dim Ar As Variant
Dim cn&, rwn&
Dim Z, Nr
Set S = Sheets(Nm)
S.Cells.Clear
For Each Sh In ThisWorkbook.Worksheets
With Sh
Select Case .Name
       Case Is = Nm, "كشف حساب", "تقارير"
       Case Else
       N_Sh = .Name
Set Rn = .Range("B21:F26")
With Rn
For Z = 1 To .Rows.Count
cn = 3
rwn = .Rows.Count
ReDim Preserve My_mx(1 To rwn, 1 To cn)
    If .Cells(Z, 4).Value > 0 Then
      If i = rwn Then GoTo 1
      i = i + 1
        Ar = Array(Sh.[B14] & " " & Application.Text(Sh.[C14], "[$-C01]dddd"), _
        Sh.[G14] & " " & Application.Text(Sh.[H14], "yyyy/mm/dd"))
        My_mx(i, 1) = CStr(.Cells(Z, 1)): My_mx(i, 2) = CStr(.Cells(Z, 4))
        My_mx(i, 3) = CStr(.Cells(Z, 5))
    End If
1 Next
End With
'==================================================
Set Rng = .Range("B32:D36")
With Rng
For Nr = 1 To .Rows.Count
cl = 3
rw = .Rows.Count
ReDim Preserve Ar_mx(1 To rw, 1 To cl)
    If .Cells(Nr, 2).Value > 0 Then
      If ii = rw Then GoTo 0
      ii = ii + 1
        Ar_mx(ii, 1) = CStr(.Cells(Nr, 1)): Ar_mx(ii, 2) = CStr(.Cells(Nr, 2))
        Ar_mx(ii, 3) = CStr(.Cells(Nr, 3))
    End If
0 Next
End With
With S
  Lr = Cells(.Rows.Count, 2).End(xlUp).Offset(2, 0).Row
  .Cells(Lr, 1).Resize(, 2) = Array(N_Sh, "مصروفات سيارة")
  .Range(.Cells(Lr + 1, 2).Address).Resize(, UBound(Ar) + 1) = Ar
  .Range(.Cells(Lr + 2, 2).Address).Resize(, 3) = Array("إسم المندوب", "مبلغ", "ملاحظات")
  .Range(.Cells(Lr + 3, 2).Address).Resize(UBound(My_mx, 1), UBound(My_mx, 2)) = My_mx
  Lrr = Cells(.Rows.Count, 2).End(xlUp).Offset(2, 0).Row
  .Cells(Lrr, 3) = "المصروفات الاخرى للسيارات"
  .Range(.Cells(Lrr + 1, 2).Address).Resize(, 3) = Array("الإسم", "قيمة المصروف", "ملاحظات")
  With .Range(.Cells(Lrr + 2, 2).Address)
   .Resize(UBound(Ar_mx, 1), UBound(Ar_mx, 2)) = Ar_mx
   Lrw = S.Cells(Rows.Count, 2).End(xlUp).Row
   With S.Range(S.Cells(Lrw, 1).Address).Resize(, 10)
    .Borders(xlDiagonalDown).LineStyle = xlNone: .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone: .Borders(xlEdgeTop).LineStyle = xlNone
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0: .Color = RGB(255, 0, 0)
        .TintAndShade = 0: .Weight = xlThin
    End With
    End With
  End With
End With
Erase My_mx: i = 0: Erase Ar_mx: ii = 0
End Select
End With
Next
End Sub

[البروفسير]

شكرا اخي عباد على مجهودك الطيب .. هذا هو المطلوب ..
ولكن عند تنفيذه اجد مشكلة RUN time 438 وانه لا يدعم هذه الحالة .
لا اعرف اين الخطأ فى الكود تحديدا ... انا استعمل اوفيس 2003 
لعل يكون هذا, السبب ؟؟

تم تعديل سبتمبر 18, 2013 بواسطه البروفسير

[الـعيدروس]

اذا الكود نتائجة سليمة

ضيف السطر التالي اول الكود

on error resume next

[البروفسير]

سلمت يداك ... شكرا اخي عباد .. الان تم الحل ..
وفقت اخي وبوركت .. تحياتى لك .. ولا تحرمنا من علمك .. بارك الله فيه ونفعك به 

[البروفسير]

اخي عباد لو انه ليس هناك مصروفات للمندوبين وهناك مصروفات صيانة للسيارات .. الكود يكرر الشيت السابق ويخطأ فى الترتيب .. جربها بنفسك فى المرفق السابق ..
ايضا الكود يكرر الشيت السابق لو كان اليوم ( الجمعة ) .. نفس المشكلة الاولى لانه ايضا لا يوجد مصروفات فى قسم المندوبين ..
عذرا لتفعيل هذا الموضوع مرة ثانية ولكن حاولت مرار ان اعدل الكود الخاص بك .. ولكنى فشلت فى ذلك . شكرا لسعة صدرك اخي العزيز

تم تعديل أكتوبر 3, 2013 بواسطه البروفسير

[الـعيدروس]

السلام عليكم

حالياً اتصفح من الجوال

الى المساء اعدلك عليه ان شاء الله

[البروفسير]

انتظرك اخي العزيز ... عذرا على ارهاقك بكثرة الطلبات

[البروفسير]

up

[الـعيدروس]

السلام عليكم

 

جرب المرفق

9-2013_A.rar