ترحيل بدون مسح المعادلات

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

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

2024-3-15 ترحيل بيانات 2.xlsm

[محمد هشام.]

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

Sub ÊÑÍíá2()
 
    Dim Ws As Worksheet, F As Worksheet
    Dim X As Long, I As Long, Arr
    Set Ws = Sheets("Home"): Set F = Sheets("data")
    X = F.Cells(Rows.Count, 2).End(3).Row + 1
   Application.ScreenUpdating = False
   Arr = Array("B2", "B3", "", "B4", "B5", "D2", "D3", "D4", "D5", "F2", "F3", "F4", "", "F5")
        For I = LBound(Arr) To UBound(Arr)
            If Arr(I) <> "" Then Arr(I) = Ws.Range(Arr(I)).Value
        Next I
            
        
         F.Cells(X, 2).Resize(, UBound(Arr) + 1) = Arr
          F.Range("D3:D" & F.Range("B" & Rows.Count).End(3).Row) = "=($D$1-C3)/(365)"
            F.Range("N3:N" & F.Range("B" & Rows.Count).End(3).Row) = "=sum(k3+l3+m3)"
             F.Cells(X, 1) = F.Cells(X, 1).Row - 2
            
     Application.ScreenUpdating = True
End Sub

او

Sub ترحيل3()
 
    Dim Ws As Worksheet, F As Worksheet
    Dim X As Long, I As Long, Arr
    Set Ws = Sheets("Home"): Set F = Sheets("data")
    X = F.Cells(Rows.Count, 2).End(3).Row + 1
   Application.ScreenUpdating = False

      Arr = Array("B2", "B3", "", "B4", "B5", "D2", "D3", "D4", "D5", "F2", "F3", "F4", "", "F5")
            For I = LBound(Arr) To UBound(Arr)
            If Arr(I) <> "" Then Arr(I) = Ws.Range(Arr(I)).Value
            
    Next I
    F.Cells(X, 2).Resize(, UBound(Arr) + 1) = Arr
    
    With F.Range("A3:A" & F.Range("B" & Rows.Count).End(xlUp).Row)
        .Formula = "=IF(B3="""","""",IF(B3=""Name"",""Count"",N(A2)+1))"
            .Value = .Value
    
    With F.Range("D3:D" & F.Range("B" & Rows.Count).End(3).Row)
          .Formula = "=($D$1-C3)/(365)"
            .Value = .Value
    
    With F.Range("N3:N" & F.Range("B" & Rows.Count).End(3).Row)
          .Formula = "=sum(k3+l3+m3)"
             .Value = .Value

                End With
         End With
    End With
   Application.ScreenUpdating = True

End Sub

 

2024-3-15 ترحيل بيانات 2.xlsm

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

استاذ / محمد هشام

اشكرك على تفاعلك 

ولكن لو كانت المعادلات متكررة في عدة اعمدة 

بين معادلات جمع وغيرة جمع ومعادات 

والجدول فيه بيانات اكثر من ثلاثة الاف

فان اعادة بناء او اضافة المعادلات من البداية سوف ياخذ وقت طويل 

لان بعضها يتم تعد يلها يدويا وتغييرها حسب الحاجة

والفكرة المطلوبه التي تحل المشكلة

هي قفز العمود وتركة  

واضافة في العامود الذي بعدة

بحيث لا تتغير المعادلات 

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

 

[محمد هشام.]

تفضل اليك الحلول التالية

Sub ترحيل1()
Dim Cpt As Long, Arr As Range, r As Range
Dim a As Worksheet: Set a = Worksheets("Home"): Dim F As Worksheet: Set F = Worksheets("data")

Cpt = F.Cells(F.Rows.Count, "B").End(xlUp).Row
  
With Application
        .Calculation = xlManual
        .ScreenUpdating = False
        
b = Array(a.[B2], a.[B3]): c = a.[F5]
d = Array(a.[B4], a.[B5], a.[D2], a.[D3], a.[D4], a.[D5], a.[F2], a.[F3], a.[F4])

'***لعدم الترحيل في حالة العثور على خلية فارغة***
'Set Arr = Union(a.[B2:B5], a.[D2:D5], a.[F2:F5])
'    For Each r In Arr
'        If IsEmpty(r.Value) Or r.Value = vbNullString Then
'          MsgBox " المرجوا ملء بيانات " & r.Offset(0, -1).Value, vbExclamation, "إنتباه"
'            Exit Sub
'        End If
'    Next r
'************************************************
 F.Cells(Cpt + 1, "A") = F.Cells(Cpt + 1, "A").Row - 2
 F.Cells(Cpt, "B").Offset(1).Resize(, 2).Value = b
 F.Cells(Cpt, "E").Offset(1).Resize(, 9).Value = d
 F.Cells(Cpt, "O").Offset(1).Value = c

.Calculation = xlAutomatic
    .ScreenUpdating = True
    End With
    
    MsgBox "تم ترحيل البيانات بنجاح", vbInformation
End Sub

او

Sub ترحيل2()
 Dim Cpt As Long

 Dim a As Worksheet: Set a = Sheets("Home"): Dim F As Worksheet: Set F = ThisWorkbook.Sheets("data")
 
 Cpt = F.Cells(F.Rows.Count, "B").End(xlUp).Row + 1

With Application
        .Calculation = xlManual
        .ScreenUpdating = False
        
    Arr = Array(a.[B2], a.[B3], a.[B4], a.[B5], a.[D2], a.[D3], a.[D4], a.[D5], a.[F2], a.[F3], a.[F4], a.[F5])
    For I = 0 To 11
        If Arr(I) = Empty Then
MsgBox " المرجوا ملء بيانات " & Arr(I).Offset(0, -1), vbExclamation, "إنتباه"
            Exit Sub
        End If
    Next
     
F.Cells(Cpt, "A") = F.Cells(Cpt, "A").Row - 2
F.Cells(Cpt, "B").Value = a.[B2].Value: F.Cells(Cpt, "G").Value = a.[D2].Value
F.Cells(Cpt, "C").Value = a.[B3].Value: F.Cells(Cpt, "H").Value = a.[D3].Value
F.Cells(Cpt, "E").Value = a.[B4].Value: F.Cells(Cpt, "I").Value = a.[D4].Value
F.Cells(Cpt, "F").Value = a.[B5].Value: F.Cells(Cpt, "J").Value = a.[D5].Value
F.Cells(Cpt, "K").Value = a.[F2].Value: F.Cells(Cpt, "L").Value = a.[F3].Value
F.Cells(Cpt, "M").Value = a.[F4].Value: F.Cells(Cpt, "O").Value = a.[F5].Value

.Calculation = xlAutomatic
    .ScreenUpdating = True
    End With
    
MsgBox "تم ترحيل البيانات بنجاح", vbInformation

End Sub

2024-3-15 ترحيل V2.xlsm

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

أستاذي الفاضل /  محمد هشام

اشكر لك سرعة تفاعلك

نعم هذا المطوب

جزاك الله خير

لك كل الشكر والتقدير