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

عمر الجزاوى · سبتمبر 27, 2023

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

الحفظ.rar

**محمد هشام.** · سبتمبر 27, 2023

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

تفضل اخي جرب

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

عمر الجزاوى · سبتمبر 27, 2023

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

**محمد هشام.** · سبتمبر 27, 2023

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

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

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

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

End Sub

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

عمر الجزاوى · سبتمبر 27, 2023

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

**محمد هشام.** · سبتمبر 28, 2023

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

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

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

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

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

عمر الجزاوى · سبتمبر 29, 2023

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

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

**محمد هشام.** · سبتمبر 30, 2023

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

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

عمر الجزاوى · سبتمبر 30, 2023

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

**محمد هشام.** · سبتمبر 30, 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 بواسطه محمد هشام.

عمر الجزاوى · أكتوبر 1, 2023

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

**محمد هشام.** · أكتوبر 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

عمر الجزاوى · أكتوبر 1, 2023

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

تسجيل الدخول

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

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

عمر الجزاوى

محمد هشام.

عمر الجزاوى

محمد هشام.

عمر الجزاوى

محمد هشام.

عمر الجزاوى

محمد هشام.

عمر الجزاوى

محمد هشام.

عمر الجزاوى

محمد هشام.

عمر الجزاوى

Join the conversation

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

تصفح الموقع

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

Support

Important Information