ترحيل العملاء

[عمر الجزاوى]

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

الحفظ.rar

[محمد هشام.]

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

تفضل اخي جرب 

Sub حفظ()
Dim myFolder As String
'خلية اسم الملف
NameSh = Range("b2")

' مجلد الحفظ
myFolder = ThisWorkbook.Path & "\السجل\" & NameSh


If NameSh = Empty Then: MH = MsgBox("المرجوا إضافة إسم الملف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "تنبيه"): Exit Sub
ActiveSheet.Copy
'(VBA)' تعطيل تنبيهات
Application.ScreenUpdating = False
Application.DisplayAlerts = False

' تحويل الصيغ الى قيم
    With ActiveSheet.UsedRange
        .Value = .Value
    End With
  ' حدف الازرار
For Each shape In ActiveSheet.Shapes
        shape.Delete
Next
  ' افراغ الخلايا التي تتضمن 0
ActiveWindow.DisplayZeros = False

  On Error Resume Next
    With ActiveWorkbook
        .SaveAs Filename:=myFolder & ".xlsx", FileFormat:=51
        
        ' في حالة الرغبة باظافة تاريخ اليوم
   ' .SaveAs Filename:=myFolder & "_" & Format(Now, "yy-mm-dd") & ".xlsx", FileFormat:=51
   
        .Close False
    End With
    On Error GoTo 0
End Sub

 

الحفظ.rar

[عمر الجزاوى]

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

[محمد هشام.]

اخي @عمر الجزاوى هدا لا علاقة له بالكود الدي قمت بارفاقه في مشاركتك الاولى .

الكود كالتالي 

Sub حفظ()
Dim fw As Variant
ActiveSheet.Copy  ' نسخ الشيت النشط
("b2") حفظ الملف في مجلد السجل في نفس مسار المصنف النشط وتسميته بالخلية
fw = ThisWorkbook.Path & "\السجل\" & Range("b2").Value & ".xlsx"   
ActiveWorkbook.SaveAs fw ' حفظ الملف

ActiveWorkbook.Close ' غلق المصنف الجديد

End Sub

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

 

[عمر الجزاوى]

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

[محمد هشام.]

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

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

لنفترض انك رحلت بيانات العميل محمد اول مرة هل يتم انشاء مصنف جديد ام اظافة شيت  باسم محمد لنفس المصنف الدي يتضمن فاضل   

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

 

 

 

تم تعديل سبتمبر 28, 2023 بواسطه محمد هشام.

[عمر الجزاوى]

شكرا استاذ محمد على متابعة الموضوع 

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

[محمد هشام.]

تمام اخي @عمر الجزاوى  ممكن ارفاق ملف  بشكل البيانات تحت بعض  لاتمكن من تحديد النطاق 

لان هناك عدة صفوف فارغة بعد الترحيل هل تحتفظ بها ام نقوم بازالتها 

 

 

 

[عمر الجزاوى]

احسن الله اليكم وجزاكم الجنة ورضى عنكم وشكرا على متابعتكم للموضوع هو ترحيل البيانات اسفل بعضها وتجاهل الصفوف الفارغة

[محمد هشام.]

تفضل اخي @عمر الجزاوى

Sub Copy_invoices()      

    Dim j&, I&, WSdest As Workbook
    Dim MyData As Workbook: Set MyData = ThisWorkbook
    Dim Customer As String, Chemin As String, LastRow As Long
    Dim MyRang As Range, LastRng As Long, DesTRng As Long
    
    Customer = MyData.Sheets(1).[b2]
    
    Chemin = ThisWorkbook.Path & "\السجل\" & Customer & ".xlsx"
    
    LastRow = MyData.Sheets(1).Cells(MyData.Sheets(1).Rows.Count, 1).End(xlUp).Row
    
    Set MyRang = MyData.Sheets(1).Range("A1:F" & LastRow)
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

If IsEmpty(Customer) Then X = MsgBox("إسم العميل غير موجود ", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "إنتباه"): Exit Sub
    If Len(Dir(Chemin)) = 0 Then
        Set WSdest = Workbooks.Add

MyRang.Copy
          
  With WSdest.Sheets(1).[A1]
      
      .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      .PasteSpecial Paste:=xlPasteFormats
      .PasteSpecial Paste:=xlPasteColumnWidths
       Sheets(1).DisplayRightToLeft = True
          Sheets(1).Name = Customer
                           
      For j = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1
         If WSdest.Sheets(1).Cells(j, 1) = "" And _
            WSdest.Sheets(1).Cells(j, 5) = "0" Then Rows(j).Delete
                      
         Next j
         
    End With
    
    [A1].Select
       WSdest.SaveAs ThisWorkbook.Path & "\السجل\" & Customer & ".xlsx", FileFormat:=51
        WSdest.Close
    
    Else
        
        Set WSdest = Workbooks.Open(Chemin)
        
        LastRng = WSdest.Sheets(1).Cells(WSdest.Sheets(1).Rows.Count, 1).End(xlUp).Row
  
    If WSdest.Sheets(1).[b2] <> "" Then DesTRng = LastRng + 3 Else DesTRng = LastRng + 1
         
MyRang.Copy
        
      With WSdest
          .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
          .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteFormats
          .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteColumnWidths
           Sheets(1).DisplayRightToLeft = True
           Sheets(1).Name = Customer
            
       End With
    
    For I = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1
       If WSdest.Sheets(1).Cells(j, 1) = "" And _
            WSdest.Sheets(1).Cells(j, 5) = "0" Then Rows(j).Delete
        
          Next
         [A1].Select
        WSdest.SaveAs ThisWorkbook.Path & "\السجل\" & Customer & ".xlsx", FileFormat:=51

        WSdest.Close
        
    End If
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

 

الحفظ 2.rar

تم تعديل أكتوبر 1, 2023 بواسطه محمد هشام.

[عمر الجزاوى]

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

[محمد هشام.]

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

بالتوفيق....

 

Sub Copy_invoices_2()

    Dim j&, I&, WSdest As Workbook
    Dim MyData As Workbook: Set MyData = ThisWorkbook
    Dim Customer As String, Chemin As String, LastRow As Long
    Dim MyRang As Range, LastRng As Long, DesTRng As Long
    Dim MyFolder, Save_Folder, MyPath As String

    Customer = MyData.Sheets(1).[b2]
   
On Error Resume Next
If IsEmpty([b2]) Then X = MsgBox("إسم العميل غير موجود ", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "إنتباه"): Exit Sub

'اسم مجلد الحفظ قم بتعديله بما يناسبك
         MyFolder = "السجل"

MyPath = Application.ActiveWorkbook.Path
   If IsEmpty(MyFolder) Then Exit Sub
    If IsEmpty(Customer) Then Exit Sub

MkDir MyPath & "\" & MyFolder
Save_Folder = MyPath & "\" & MyFolder & "\" & Customer

    
    Chemin = Save_Folder & ".xlsx"
    
    LastRow = MyData.Sheets(1).Cells(MyData.Sheets(1).Rows.Count, 1).End(xlUp).Row
    
    Set MyRang = MyData.Sheets(1).Range("A1:F" & LastRow)
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False


    If Len(Dir(Chemin)) = 0 Then
        Set WSdest = Workbooks.Add

MyRang.Copy
          
  With WSdest.Sheets(1).[A1]
      
      .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      .PasteSpecial Paste:=xlPasteFormats
      .PasteSpecial Paste:=xlPasteColumnWidths
       Sheets(1).DisplayRightToLeft = True
          Sheets(1).Name = Customer
                           
      For j = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1
            If WSdest.Sheets(1).Cells(j, 1) = "" And _
            WSdest.Sheets(1).Cells(j, 5) = "0" Then Rows(j).Delete
                      
         Next j
         
    End With
    
    [A1].Select
       WSdest.SaveAs Save_Folder & ".xlsx", FileFormat:=51
        WSdest.Close
    
    Else
        
        Set WSdest = Workbooks.Open(Chemin)
        
        LastRng = WSdest.Sheets(1).Cells(WSdest.Sheets(1).Rows.Count, 1).End(xlUp).Row
  
    If WSdest.Sheets(1).[b2] <> "" Then DesTRng = LastRng + 3 Else DesTRng = LastRng + 1
         
MyRang.Copy
        
      With WSdest
          .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
          .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteFormats
          .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteColumnWidths
           Sheets(1).DisplayRightToLeft = True
           Sheets(1).Name = Customer
            
       End With
    
    For I = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1
        If WSdest.Sheets(1).Cells(I, 1) = Empty And WSdest.Sheets(1).Cells(I, 5) = "0" Then Rows(I).Delete
        
          Next
         [A1].Select
        WSdest.SaveAs Save_Folder & ".xlsx", FileFormat:=51

        WSdest.Close
        
    End If
    

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

الديباجة 4.xlsb

[عمر الجزاوى]

الله عليك استاذ محمد لما تبدع لااستطيع اعبر لك عن مدى فرحتى بعملك الجميل الله يجزيكم الجنة ويسكنكم الفردوس الاعلى