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

البروفسير · سبتمبر 17, 2013

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

.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

البروفسير · سبتمبر 17, 2013

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

**الـعيدروس** · سبتمبر 17, 2013

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

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

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

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

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

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

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

تحياتي

البروفسير · سبتمبر 17, 2013

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

9-2013.rar

**الـعيدروس** · سبتمبر 18, 2013

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

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

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

البروفسير · سبتمبر 18, 2013

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

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

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) ]

**الـعيدروس** · سبتمبر 18, 2013

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

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

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

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

البروفسير · سبتمبر 18, 2013

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

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

**الـعيدروس** · سبتمبر 18, 2013

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

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

on error resume next

البروفسير · سبتمبر 19, 2013

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

البروفسير · أكتوبر 3, 2013

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

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

**الـعيدروس** · أكتوبر 3, 2013

السلام عليكم

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

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

البروفسير · أكتوبر 4, 2013

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

البروفسير · أكتوبر 4, 2013

up

**الـعيدروس** · أكتوبر 5, 2013

السلام عليكم

جرب المرفق

9-2013_A.rar

تسجيل الدخول

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

الردود الموصى بها

البروفسير

البروفسير

الـعيدروس

البروفسير

الـعيدروس

البروفسير

الـعيدروس

البروفسير

الـعيدروس

البروفسير

البروفسير

الـعيدروس

البروفسير

البروفسير

الـعيدروس

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

انشئ حساب جديد

تسجيل دخول

محتوي مشابه

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

استدعاء بيانات من فاتورة

ترحيل اسهل طريقة لعمل ترحيل للسجلات وعدم امكانية رؤيتهم بالنموذج بعد الترحيل

كود ترحيل البيانات من صفحة الى أخرى

طلب - اضافة بيانات لليست بوكس عن طريق كومبوبكس و تكستات باستخدام زر اضافة ثم ترحيل لورقة الاكسيل

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information