ترحيل وتعديل وحذف بيانات

[أحمد محمد اسماعيل عامر]

هلا lionheart

 

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

@lionheart

Dynamic Orders - Pivot.xlsm

[محمد هشام.]

تفضل جرب اخي لاكن حاول دائما  عدم طلب اكثر من طلب في موضوع واحد  لكي يستطيع الاساتدة مساعدتك. لا احد لديه الوقت الكافي لاتمام كل الطلبات ...عند الانتهاء من ترحيل البيانات بنجاح قم بفتح وضوع جديد. وسوف نكون سعداء بمساعدتك.

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

 

Sub Transfer()                        '  ترحيل
Dim rng As Range, line As Range, cl As Range
Dim C As Long, lastrow As Long
Dim msg As VbMsgBoxResult

Dim WSdata As Worksheet: Set WSdata = Worksheets("Items")
Dim WSdest As Worksheet: Set WSdest = Worksheets("Orders")
lastrow = WSdest.Cells(WSdest.Rows.Count, "C").End(xlUp).Row

Application.ScreenUpdating = False

'التحقق من وجود بيانات على الخلايا التالية
   WSdata.Activate
    Arr = Array([F4], [F6], [H6], [H9], [H9], [F13], [H13], [J13])
    For i = 0 To 7
        If Arr(i) = Empty Then
MsgBox " المرجوا ملء بيانات " & Arr(i).Offset(0, -1), vbExclamation, "إنتباه"
            Arr(i).Select
            Exit Sub
        End If
      
    Next
'التحقق من وجود  اسم العميل مسبقا  لمنع التكرار

If Application.WorksheetFunction.CountIf(WSdest.Range("D:D"), WSdata.Range("F4").Value) > 0 Then
 MsgBox "إسم العميل مضاف مسبقا", vbExclamation, "إنتباه"
 Exit Sub
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
msg = MsgBox("ترحيل البيانات ؟ ", vbYesNo + vbQuestion + vbDefaultButton2, "")
    If msg = vbNo Then
    Exit Sub
Else
End If

Set rng = WSdata.Range("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,J18,F20,H20")
C = 3
For Each cl In rng
    cl.Copy
    WSdest.Cells(lastrow + 1, C).PasteSpecial xlPasteValues
    C = C + 1
Next cl
'تسلسل البيانات
With WSdest.Range("B7:B" & lastrow + 1)
        .Formula = "=Row() - 6"
        .Value = .Value
    End With
Application.CutCopyMode = False
'حدف الصفوف الفارغة
On Error Resume Next
Set line = Range("Orders[[إسم العميل]]").SpecialCells(xlCellTypeBlanks)
If Not line Is Nothing Then
line.Delete Shift:=xlUp
End If
On Error GoTo 0
'افراغ الخلايا
WSdata.Range("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,F20,H20") = Empty
Application.ScreenUpdating = True

 m = MsgBox("تم ترحيل البيانات بنجاح", 64, "تأكيد")
End Sub

 

 

تم تعديل يونيو 2, 2023 بواسطه Mohamed Hicham

[محمد هشام.]

تفضل اخي كود لنقل البيانات من شيت (Ordres) الى شيت (Items) بدوبل كليك على عمود اسم العميل 

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Dim lastrow As Long
Dim Row_Clt As Worksheet: Set Row_Clt = Worksheets("Items")
Dim sh As Worksheet: Set sh = Worksheets("Orders")
lastrow = sh.Cells(sh.Rows.Count, "d").End(xlUp).Row
Set ws_data = ActiveCell
 If Intersect(Target, Range("D7:D" & lastrow)) Is Nothing Then
 Else
   Application.ScreenUpdating = False
    Row_Clt.Range("F4") = ws_data.Value
    Row_Clt.Range("F6") = ws_data.Offset(0, 1).Value
    Row_Clt.Range("H6") = ws_data.Offset(0, 2).Value
    Row_Clt.Range("F9") = ws_data.Offset(0, 3).Value
    Row_Clt.Range("H9") = ws_data.Offset(0, 4).Value
    Row_Clt.Range("J9") = ws_data.Offset(0, 5).Value
    Row_Clt.Range("F13") = ws_data.Offset(0, 6).Value
    Row_Clt.Range("H13") = ws_data.Offset(0, 7).Value
    Row_Clt.Range("J13") = ws_data.Offset(0, 8).Value
    Row_Clt.Range("F15") = ws_data.Offset(0, 9).Value
    Row_Clt.Range("H15") = ws_data.Offset(0, -1).Value
    Row_Clt.Range("J15") = ws_data.Offset(0, 10).Value
    Row_Clt.Range("F18") = ws_data.Offset(0, 11).Value
    Row_Clt.Range("H18") = ws_data.Offset(0, 12).Value
    Row_Clt.Range("F20") = ws_data.Offset(0, 14).Value
    Row_Clt.Range("H20") = ws_data.Offset(0, 15).Value
 End If
 On Error GoTo 0
 Application.ScreenUpdating = True
 End Sub

واليك الملف بعد اظافة اكواد الترحيل والتعديل والحدف 

 

Dynamic Orders - Pivot_V3.xlsm

[أحمد محمد اسماعيل عامر]

أخي الحبيب جزاك الله خير الجزاء وبوركت الجنة إن شاء الله

 

فيه مشكلة إنه لما بقف على خانة العميل بيمسح كل العميل اللي بنفس الأسم في الجدول كله 

وأنا أريده أن يمسح الطلبية هذه فقط (الصف فقط)

كذلك المشكلة الثانية بالكود هي عدم إضافة أسم العميل مكرر

 

 حيث هذا نموذج صرف يومي ويوجد تكرار للعميل الواحد لأكثر من بند وأعمال ومراحل ومورد وهكذا

 

تم تعديل بعض الملاحظات  على النموذج المرفق أرجو التعديل عليه

وجزاكم الله خيرا الجزاء إن شاء الله

 

@Mohamed Hicham

 

Dynamic Orders - Pivot_V4.xlsm

[محمد هشام.]

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

[أحمد محمد اسماعيل عامر]

هلا بحضرتك .. أنا آسف لقد خانني التعبير

أريد عند الضغط على الصف مرتين زي ما حضرتك عملت كده وبعد تحميل البيانات في جدول الـ items

بعدها يتم الحذف للصف المختار بالكامل

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

 

@Mohamed Hicham

Dynamic Orders - Pivot_V5.xlsm

تم تعديل يونيو 2, 2023 بواسطه أحمد محمد اسماعيل عامر

[محمد هشام.]

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

Sub Délete_Client()          ' حدف
Dim WS As Worksheet, WS2 As Worksheet
Dim i As Long, ST As Long
Dim msg As VbMsgBoxResult, Client As String
Set WS = Worksheets("Orders")
Set WS2 = Worksheets("Items")
Client = WS2.Range("F4")
N_row = WS2.Range("W1")
Application.ScreenUpdating = False
If Client = Empty Then
MsgBox Client & "المرجوا تحديد الصف المراد حدف بياناته", vbExclamation, "إنتباه"
Exit Sub
End If

msg = MsgBox(" هل انت متأكد من حدف : " & Client, vbYesNo + vbQuestion + vbDefaultButton2, "إنتباه")
Application.ScreenUpdating = False
    If msg = vbNo Then
Exit Sub
End If
WS.Activate
    For i = Cells(Rows.Count, 2).End(xlUp).Row To 7 Step -1
        If Cells(i, 2).Value = N_row Then
            Rows(i).Delete
        End If
    Next i
For ST = 7 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(ST, "c").Value <> "" Then
Cells(ST, "b").Value = ST - 6
End If
Next ST
WS2.Activate
WS2.Range("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,F20,J21,w1") = Empty
Application.ScreenUpdating = True
 m = MsgBox("تم حدف البيانات بنجاح", 64, "تأكيد")

End Sub

 

Dynamic Orders - Pivot_V6.xlsm

[أحمد محمد اسماعيل عامر]

الله يجزاك كل ماهو فيه الخير

 

عندي طلب آخير على هذا النموذج سوف أرفقه في موضوع جديد