تكرما تعديل كود الترحيل

[J Abuabdullah]

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

يشير بان هناك خطاء .. 

ارجوا التكرم بلاطلاع وتبين المشلكة ... ولكم بالغ التقدير 

علما بانني استخدم اخر اصدارات اوفيس /  على جهاز ماك

Sub insert02()


Dim Mj As Worksheet
Dim Mn As String
Dim Mt As worksheet
Dim the last As Integer
Set Mj = ThisWorkbook.sheets = ("Main") 
Mn = Mj.Range("L2").Value
Set Mt = ThisWorkbook.Sheets (Mn)
last = Mt.Range("B10000").End(xlUp).Row + 1
With Mt
.Cells(last, "B").Value = Mj.Range("K5").Value
Cells(last, "C").Value = Mj.Range("K6").Value
Cells(last, "D").Value = Mj.Range("K7").Value
Cells(last, "E").Value = Mj.Range("K8").Value
Cells(last, "F").Value = Mi.Range("K9").Value
Cells(last, "G").Value = Mj.Range("K10").Value
Cells(last, "H").Value = Mj.Range("K11").Value
Cells(last, "I").Value = Mj.Range("K12").Value
Cells(last, "J").Value = Mj.Range("K13").Value
Cells(last, "K").Value = Mj.Range("K14").Value
Mj.Range("K5").Value = ""
Mj.Range("K6").Value = ""
Mj.Range("K7").Value = ""
Mj.Range("K8").Value = ""
Mj.Range("K9").Value = ""
Mj.Range("K10").Value = ""
Mj.Range("K11").Value = ""
Mj.Range("K12").Value = ""
Mj.Range("K13").Value = ""
Mj.Range("K14").Value = ""

End With
End Sub

 

[alliiia]

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

لماذا لم تكمل جميلك وترفع الملف؟؟
وتشرح مشكلتك؟

على العموم جرب هذه:

Sub insert02()
    Dim Mj As Worksheet
    Dim Mn As String
    Dim Mt As Worksheet
    Dim last As Integer
    Set Mj = ThisWorkbook.Sheets("Main")
    Mn = Mj.Range("L2").Value
    On Error Resume Next
    Set Mt = ThisWorkbook.Sheets(Mn)
    On Error GoTo 0
    If Mt Is Nothing Then
        MsgBox "ورقة العمل '" & Mn & "' غير موجودة. تحقق من الاسم في الخلية L2.", vbExclamation
        Exit Sub
    End If
   last = Mt.Range("B10000").End(xlUp).Row + 1
    With Mt
        .Cells(last, "B").Value = Mj.Range("K5").Value
        .Cells(last, "C").Value = Mj.Range("K6").Value
        .Cells(last, "D").Value = Mj.Range("K7").Value
        .Cells(last, "E").Value = Mj.Range("K8").Value
        .Cells(last, "F").Value = Mj.Range("K9").Value
        .Cells(last, "G").Value = Mj.Range("K10").Value
        .Cells(last, "H").Value = Mj.Range("K11").Value
        .Cells(last, "I").Value = Mj.Range("K12").Value
        .Cells(last, "J").Value = Mj.Range("K13").Value
        .Cells(last, "K").Value = Mj.Range("K14").Value
    End With
    Mj.Range("K5:K14").ClearContents
End Sub

[J Abuabdullah]

في البداية اود ان اقدم الشكر الجزيل

واعتذر عن عدم رفع الملف في المرة السابقة .. خمنت ان الكود يكفي

ع العموم قمت باضافة الكود على الملف 

واصبح يعمل .. 🙂

لكن في نهاية الكود هناك حذف او تفريع لجدول الادخال

وانا عملت معادلة vlockup في خانة اسم المورد .. وتختفي كلما تم الاجراء

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

هل بالامكان التعديل .. لطفا

 

الملف مرفق ..

ادخال البيانات.xlsm

[alliiia]

مرحبا أخي 
نعم راح يفرغ الجدول لأن الكود يحتوي على تفريغ:

  Mj.Range("K5:K14").ClearContents

لذلك قمت بعمل ملف آخر جديد

وكتابة كود آخر جديد
يقوم بما تريده بإذن الله بشكل جميل 

 

أي ملاحظة أنا حاضر.

 

ادخال البيانات.xlsm

هذه أكواد تفريغ شاشة الإدخال:

    sourceSheet.Range("H4").ClearContents
    sourceSheet.Range("H6").ClearContents
    sourceSheet.Range("H7").ClearContents
    sourceSheet.Range("H8").ClearContents
    sourceSheet.Range("H9").ClearContents
    sourceSheet.Range("H10").ClearContents
    sourceSheet.Range("H11").ClearContents
    sourceSheet.Range("H13").ClearContents

 

احذف الذي لا تريده وابقي على الذي تريده

 

[محمد هشام.]

Sub Transfer()
Dim Rng As Range, cl As Range, WS As String
Dim C As Long, lastrow As Long

Dim WSdata As Worksheet: Set WSdata = Worksheets("Main"): WS = WSdata.[l2]
If WSdata.[l2] = 0 Then
        MsgBox "الرجاء اختيار ورقة العمل", vbOKOnly + vbExclamation, "Admin"
        Exit Sub
    End If
Dim WSdest As Worksheet: Set WSdest = ThisWorkbook.Sheets(WS)
    
    Arr = Array([k5], [k6], [k7], [k8], [k9], [k10], [k11], [k12], [k13], [k14])
    For i = 0 To 9
        If Arr(i) = Empty Then
MsgBox " المرجوا ملء بيانات " & Arr(i).Offset(0, -2), vbExclamation, "إنتباه"
            Arr(i).Select
            Exit Sub
        End If
    Next
    
  If MsgBox("ترحيل البيانات الى ورقة  " & WSdata.[l2] & " ؟", vbYesNo, "admin") = vbNo Then
        Exit Sub
    End If
    
Application.ScreenUpdating = False
lastrow = WSdest.[b10000].End(xlUp).Row
Set Rng = WSdata.Range("k5,k6,k7,k8,k9,k10,k11,k12,k13,k14")
C = 2
For Each cl In Rng
    cl.Copy
    WSdest.Cells(lastrow + 1, C).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    C = C + 1
Next cl
Application.CutCopyMode = False
Rng.SpecialCells(xlCellTypeConstants, 23).ClearContents
Application.ScreenUpdating = True

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

 

ادخال البيانات2.xlsb

[J Abuabdullah]

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

 

عمل جميل ومبدع .. 

بارك الله فيك

انا على يقين باذن الله تعالى بانكم لن تبخلوا علينا بأي معلومة مفيدة باذن الله

 

وفقكم الله ..