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

[ابوعلي الحبيب]

السلام عليكم 

 

 

 

الاخوه الكرام 

 

امل المساعدة

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

 

مثل ترحيل من ورقه 1

مطلوب ترحيل خليه a1 b1  g1 f1

الى ورقة 2

 

مكتوب في المعادله 

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

a1 , b1,"","", g1, f1

المشكله ان الاعمدة التي يتخطها الترحيل 

يقوم الكود بمسح المعادلات الموجوده في ورقه 2

 

ماهو الحل لكي تظل المعادلات كماهي 

 

ولكم الشكررررر

[shreif mohamed]

وعليكم السلام

من فضلك ارفق ملف العمل حتي يتثني لنا فهم المطلوب بشكل افضل

 

[ابوعلي الحبيب]

تم ارفاق ملف 

كود ترحيل.xlsm

[ابوعلي الحبيب]

امل المساعدة 

[سليم حاصبيا]

جرب هذا الماكرو(يمكن اضافته الى الماكرو الاساسي اذا اردت)

Sub salim_formula()
Sheets("bbb").Select
 Dim k%
 Dim t$
 Dim Final_Row%
 For k = 9 To 20
  Final_Row = Cells(Rows.Count, k).End(3).Row
   Select Case k
    Case 9:   t = "=SUM($D3+$E3)"
    Case 10:  t = "=SUM($b3+$C3)"
    Case 12:  t = "=SUM($K3+$H3)"
    Case 14:  t = "=SUM($M3+$K3)"
    Case 16:  t = "=SUM($O3+$M3)"
    Case 17:  t = "=SUM($P3+$N3)"
    Case 18:  t = "=SUM($Q3+$O3)"
    Case 19:  t = "=SUM($R3+$P3)"
    Case 20:  t = "=SUM($S3+$Q3)"
    Case Else
     GoTo Next_K
       End Select
     Cells(3, k).Resize(k).Formula = t
Next_K:
    Next
End Sub

 

[ابوعلي الحبيب]

اخي الكريم 

اشكرك على الرد 

 

ولكن المعادلات عندي تختلف فبها قائمة منسدله وغيره 

والكود هذا طويل 

 

اريد تعديل بسيط بتخطي هذي الخلايا 

 

[ابوعلي الحبيب]

مساعدة  ياكرام

[ابوعلي الحبيب]

مساعدة  ياكرام

 

[ابوعلي الحبيب]

مساعدة  ياكرام

 

 

 

[ابوعلي الحبيب]

مساعدة  ياكرام

 

 

[ابوعلي الحبيب]

مساعدة  ياكرام

 

 

 

 

 

 

[ابوعلي الحبيب]

للاسف لم اجد  

مساعدة

انتظاري كل هذي الايم بدون فائدة

 

مؤسف جدا ان لا اجد المساعدة في  هذا المنتدى 

[أسامة البراوى]

تفضل الكود

Sub CopyData()


    Dim WS As Worksheet, SH As Worksheet
    Dim x As Long, i As Long, Arr
    Set WS = Sheets("aaa"): Set SH = Sheets("bbb")
    x = SH.Cells(Rows.Count, 2).End(3).Row + 1
      
   
    Application.ScreenUpdating = False
            Arr = Array("C2", "C3", "C6", "F2", "F3", "F4", "F5", "", "", "F6", "", "F7", "", "F8", "", "", "", "", "", "F9", "C7", "C8", "C9", "C10", "C11", "C12")
            For i = LBound(Arr) To UBound(Arr)
                If Arr(i) <> "" Then Arr(i) = WS.Range(Arr(i)).Value
                If IsEmpty(Arr(i)) Then MsgBox "البيانات غير كاملة يرجى إكمال كافة الحقول": Exit Sub
            Next i
        
        
            With SH
                .Cells(x, 1) = .Cells(x, 1).Row - 2
                For i = LBound(Arr) To UBound(Arr)
                    If Arr(i) <> "" Then .Cells(x, i + 2) = Arr(i)
                   Next
                End With
             MsgBox "تم الاضافة بنجاح", vbInformation
            
     Application.ScreenUpdating = True
End Sub
         

 

[ابوعلي الحبيب]

 

استاذ / أسامة البراوى 

 

الـلـه يــســعـدك بالـدنيا والاخرة
ويرزقك الصحة والعافية

ويصلحلك النية والذرية

ويرزقــك من واسع فضله

و يــجــزاك الـجـــنة انــت وانـا

و والـدينـا وجـميـع المسلمين

 

 

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

ولك جزيل الشكر 

هذا الموضوع 

لم اجد احد يساعدني