اذهب الي المحتوي
أوفيسنا

احتاج كود لنقل بيانات محددة من شيت لاخر بنفس الشيت


سالي

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

الاستاذ ابو نصار

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

ايضا اتمني يكون اسم شيت الفاتورة ليس مبيعات فقط بل مبيعات ورقم الفاتورة " مبيعات 8 " مثلا

مع شكري لكم سلفا

رابط هذا التعليق
شارك

السلام عليكم

الاخت الكريمة سالي

اذهبي الى هذ السطر في الكود


full_path = "D:\فواتير\المبيعات" 'ThisWorkbook.Path & "\" & [i5].Value & " مبيعات

وأستبدليه بهذا

full_path = "D:\فواتير\المبيعات" & "\" 'ThisWorkbook.Path & "\" & [i5].Value & " مبيعات"

وخصوص تسمية الورقة بأسم الفاتور وأسم الورقة لم ارى اي سطر في الكود يقوم بما ذكرتيه

ارجو ارفاق نسخه من ملفك ولو به بيانات خاصه اضفيفي بيانات وهميه وارفقيه

وإن شاء الله سيتم عمل اللازم

رابط هذا التعليق
شارك

<p style="text-align: center;"><span style="color: rgb(0, 0, 205);"><strong>الاستاذ ابو نصار</strong></span></p>

<p style="text-align: center;"><span style="color: rgb(0, 0, 205);"><strong>مرفق شيت الفاتورة وهو في الاصل لاحد الاساتذة في هذا المنتدي </strong></span></p>

<p style="text-align: center;"><span style="color: rgb(0, 0, 205);"><strong>عند الضغط علي &quot; طبع &quot; للفاتورة رقم 2 ينسخ الفاتورة بشيت مستقل في نفس الفولدر </strong></span></p>

<p style="text-align: center;"><span style="color: rgb(0, 0, 205);"><strong>ويكون الاسم &quot;مبيعات 2&quot; وعند تغيير رقم الفاتورة الي 3 ينسخ شيت باسم </strong></span></p>

<p style="text-align: center;"><span style="color: rgb(0, 0, 205);"><strong>&quot;مبيعات 3 &quot; وهكذا </strong></span></p>

<p style="text-align: center;"><span style="color: rgb(0, 0, 205);"><strong>الا اني اتمني ان يكون النسخ في فولدر اسمه  مبيعات موجود في فولدر فواتيير بال D</strong></span></p>

<p style="text-align: center;"><span style="color: rgb(0, 0, 205);"><strong>وبنفس الالية مبيعات 1 ومبيعات 2 ومبيعات 3 وهكذا</strong></span></p>

<p style="text-align: center;"><span style="color: rgb(0, 0, 205);"><strong>حيث سيكون بفولدر الفواتير فولدر لمدفوعات الموردين وايضا فولدر لمقبوضات العملاء</strong></span></p>

<p style="text-align: center;"> </p>

<p style="text-align: center;"><span style="color: rgb(178, 34, 34);"><strong>ايضا في بداية الكود امر طباعة &quot; نسخة &quot; ممكن تعديله ليكون  نسختين او اكثر؟؟</strong></span></p>

<p style="text-align: center;"><span style="color: rgb(0, 0, 205);"><strong>وااسف لاني اخذت من وقتكم بارك الله فيكم</strong></span></p>

<p style="text-align: center;"><span style="color: rgb(0, 0, 205);"><strong>ولكم كل شكري</strong></span></p>

فاتورة.rar

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

الاستاذ الفاضل ابو نصار

مرفق شيت الفاتورة وهو في الاصل لاحد الاساتذة في هذا المنتدي

عند الضغط علي طبع " الفاتورة رقم 2 " ينسخ الفاتورة بشيت مستقل في نفس الفولدر ويكون الاسم "مبيعات 2 "

وعند تغيير رقم الفاتورة الي 3 ينسخ شيت "مبيعات 3 " وهكذا الا اني اتمني ان يكون النسخ في فولدر اسمه مبيعات موجود في فولدر فواتير

بال D وبنفس الالية ( مبيعات 1 ومبيعات 2 ومبيعات 3 وهكذا حيث سيكون بفولدر الفواتير فولدر لمدفوعات الموردين وايضا فولدر لمقبوضات العملاء )

ايضا في بداية الكود امر طباعة نسخة ممكن تعديله ليكون نسختين او اكثر

وااسف لاني اخذت من و قتكم بارك الله فيكم ولكم كل شكري

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

السلام عليكم

جربي هكذا عله يفي بالغرض


'*************************************************

Public Nm_Work As String

' هنا تحددي مسار ملف المبيعات

Private Const Path_A As String = "D:\المبيعات\فواتير\"

' هنا تحددي مسار ملف المدفوعات

'انشئي مجلد بأسم ' مدفوعات الموردين

Private Const Path_A1 As String = "D:\المبيعات\فواتير\مدفوعات الموردين\"

' هنا تحددي مسار ملف المقبوضات

'انشئي مجلد بأسم ' مقبوضات العملاء

Private Const Path_A2 As String = "D:\المبيعات\فواتير\مقبوضات العملاء\"

'*************************************************

Public Sub Ali_Sale()

' 1 = مسار الملف المحدد أعلى الكود

' 2 = تحديد خلية التي بها رقم المستند

' 3 = حفظ الملف بأسم

Nm_Work = "  مبيعات"

save_file Path_A, [I5], Nm_Work

End Sub

Public Sub Ali_Payment()

' 1 = مسار الملف المحدد أعلى الكود

' 2 = تحديد خلية التي بها رقم المستند

' 3 = حفظ الملف بأسم

Nm_Work = "  مدفوعات"

save_file Path_A1, [I5], Nm_Work

End Sub

Public Sub Ali_Proceed()

' 1 = مسار الملف المحدد أعلى الكود

' 2 = تحديد خلية التي بها رقم المستند

' 3 = حفظ الملف بأسم

Nm_Work = "  مقبوضات"

save_file Path_A2, [I5], Nm_Work

End Sub

Public Sub save_file(Path_x As String, m_r As Range, ByVal Fom_n As String)

Dim full_path As String

Dim aah As String

Dim Ali_Num$

Dim Num%

If ActiveSheet.CheckBox1.Value = True Then

'***************************

Ali_Num = InputBox("إدخل عدد نسخ الطباعه", "منتدى أوفسينا")

If Ali_Num = "False" Or Ali_Num = Cancel Then Exit Sub

On Error Resume Next

'***************************

For Num = 1 To Ali_Num

Activewindow.SelectedSheets.PrintOut

Next

'***************************

Exit Sub

Else

GoTo 1

End If

1:

If Range("i5") = "" Then

MsgBox ("ادخل رقم الفاتوره")

Exit Sub

Else

m = ActiveWorkbook.Name

Workbooks.Add

N = ActiveWorkbook.Name

Windows(m).Activate

ActiveSheet.Range("b1:j23").Copy

Windows(N).Activate

ActiveSheet.Range("b1:j23").Select

ActiveSheet.Paste

  Range("b1:j23").Select

    Selection.Copy

Range("b1:j23").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

	    :=False, Transpose:=False

Columns("b:J").EntireColumn.AutoFit

Range("b1").Select

Application.CutCopyMode = False

Application.DisplayAlerts = False

If aah = [I5] & ".xls" Then

MsgBox "الملف موجود بالفعل..."

ActiveWorkbook.Close

Application.DisplayAlerts = True

Exit Sub

Else

'*************************************************

ActiveWorkbook.SaveAs Filename:=Path_x & m_r & Fom_n

'*************************************************

Application.DisplayAlerts = True

ActiveWorkbook.Close

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

End If

End If

End Sub

فاتورة_A.rar

تم تعديل بواسطه عباد
رابط هذا التعليق
شارك

الله يبارك فيك استاذ ابو نصار

الله يجازيك عني خيرا

اكثر من رائع

وان شاء الله احاول اني اتابع اكواد الطباعة حتي اتمكن من التحكم في عدد نسخ الطبع

لان هذا الكود يطبع نسخة واحدة


If ActiveSheet.CheckBox1.Value = True Then

Activewindow.SelectedSheets.PrintOut

والله والله اعجز عن شكركم

حفظكم الله

رابط هذا التعليق
شارك

الظاهر أنك حملتي المرفق

وقت كنت اعدل لهذا الغرض

سبحان الله

ارجو منك تنزيل المرفق مره اخرى

تم تعديل بواسطه عباد
رابط هذا التعليق
شارك

انا اسفة اني علقت علي الطبع

والله ما قصدي الا ان اخفف من طلباتي

ممتاز جدا تسلم ايها الاستاذ العظيم والعظمة لله

لكن ملاحظة صغيرة

لدي نقل الكود الي برنامجي واسم المايكرو فيه هو ( طبع_فاتورة_المبيعات )

يظهر خطأ حتي بعد ان عدلت التالي



Public Sub Ali_Sale()

Public Sub طبع_فاتورة_المبيعات()

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

Public Sub Ali_Sale()

Nm_Work = " مبيعات"

save_file Path_A, [I5], Nm_Work

End Sub

Public Sub save_file(Path_x As String, m_r As Range, ByVal Fom_n As String)

Dim full_path As String

Dim aah As String

Dim Ali_Num$

Dim Num%

If ActiveSheet.CheckBox1.Value = True Then

'***************************

Ali_Num = InputBox("ادخل عدد نسخ الطبع")

If Ali_Num = "False" Or Ali_Num = Cancel Then Exit Sub

On Error Resume Next

'***************************

For Num = 1 To Ali_Num

Activewindow.SelectedSheets.PrintOut

Next

'***************************

Exit Sub

Else

GoTo 1

End If

1:

If Range("i5") = "" Then

MsgBox ("ادخل رقم الفاتورة")

Exit Sub

Else

m = ActiveWorkbook.Name

Workbooks.Add

N = ActiveWorkbook.Name

Windows(m).Activate

ActiveSheet.Range("b1:j23").Copy

Windows(N).Activate

ActiveSheet.Range("b1:j23").Select

ActiveSheet.Paste

Range("b1:j23").Select

Selection.Copy

Range("b1:j23").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Columns("b:J").EntireColumn.AutoFit

Range("b1").Select

Application.CutCopyMode = False

Application.DisplayAlerts = False

If aah = [I5] & ".xls" Then

MsgBox "الملف موجود بالفعل..."

ActiveWorkbook.Close

Application.DisplayAlerts = True

Exit Sub

Else

'*************************************************

ActiveWorkbook.SaveAs Filename:=Path_x & m_r & Fom_n

'*************************************************

Application.DisplayAlerts = True

ActiveWorkbook.Close

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

End If

End If

End Sub

اتصور لازم اقوم بتعديل شيء حتي يعمل معي

الله يبارك فيك يارب

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

الاكواد المرتبطه بالكود الاساسي هي ثلاثه

هذا الكود يحدد لزر المبيعات


Public Sub Ali_Sale()

' 1 = مسار الملف المحدد أعلى الكود

' 2 = تحديد خلية التي بها رقم المستند

' 3 = حفظ الملف بأسم

Nm_Work = "  مبيعات"

save_file Path_A, [I5], Nm_Work

End Sub

وهذا لزر المدفوعات

Public Sub Ali_Payment()

' 1 = مسار الملف المحدد أعلى الكود

' 2 = تحديد خلية التي بها رقم المستند

' 3 = حفظ الملف بأسم

Nm_Work = "  مدفوعات"

save_file Path_A1, [I5], Nm_Work

End Sub

وهذا لزر المقبوضات

Public Sub Ali_Proceed()

' 1 = مسار الملف المحدد أعلى الكود

' 2 = تحديد خلية التي بها رقم المستند

' 3 = حفظ الملف بأسم

Nm_Work = "  مقبوضات"

save_file Path_A2, [I5], Nm_Work

End Sub

وإن كان لكل واحد ملف فلابد من نسخ الاكود فرضا المبيعات بيكون كالتالي

Public Nm_Work As String

' هنا تحددي مسار ملف المبيعات

Private Const Path_A As String = "D:\المبيعات\فواتير\"

Public Sub Ali_Sale()

' 1 = مسار الملف المحدد أعلى الكود

' 2 = تحديد خلية التي بها رقم المستند

' 3 = حفظ الملف بأسم

Nm_Work = "  مبيعات"

save_file Path_A, [I5], Nm_Work

End Sub

Public Sub save_file(Path_x As String, m_r As Range, ByVal Fom_n As String)

Dim full_path As String

Dim aah As String

Dim Ali_Num$

Dim Num%

If ActiveSheet.CheckBox1.Value = True Then

'***************************

Ali_Num = InputBox("إدخل عدد نسخ الطباعه", "منتدى أوفسينا")

If Ali_Num = "False" Or Ali_Num = Cancel Then Exit Sub

On Error Resume Next

'***************************

For Num = 1 To Ali_Num

Activewindow.SelectedSheets.PrintOut

Next

'***************************

Exit Sub

Else

GoTo 1

End If

1:

If Range("i5") = "" Then

MsgBox ("ادخل رقم الفاتوره")

Exit Sub

Else

m = ActiveWorkbook.Name

Workbooks.Add

N = ActiveWorkbook.Name

Windows(m).Activate

ActiveSheet.Range("b1:j23").Copy

Windows(N).Activate

ActiveSheet.Range("b1:j23").Select

ActiveSheet.Paste

  Range("b1:j23").Select

    Selection.Copy

Range("b1:j23").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

	    :=False, Transpose:=False

Columns("b:J").EntireColumn.AutoFit

Range("b1").Select

Application.CutCopyMode = False

Application.DisplayAlerts = False

If aah = [I5] & ".xls" Then

MsgBox "الملف موجود بالفعل..."

ActiveWorkbook.Close

Application.DisplayAlerts = True

Exit Sub

Else

'*************************************************

ActiveWorkbook.SaveAs Filename:=Path_x & m_r & Fom_n

'*************************************************

Application.DisplayAlerts = True

ActiveWorkbook.Close

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

End If

End If

End Sub

وهكذا للمدفوعات

Public Nm_Work As String

Private Const Path_A1 As String = "D:\المبيعات\فواتير\مدفوعات الموردين\"

Public Sub Ali_Payment()

' 1 = مسار الملف المحدد أعلى الكود

' 2 = تحديد خلية التي بها رقم المستند

' 3 = حفظ الملف بأسم

Nm_Work = "  مدفوعات"

save_file Path_A1, [I5], Nm_Work

End Sub

Public Sub save_file(Path_x As String, m_r As Range, ByVal Fom_n As String)

Dim full_path As String

Dim aah As String

Dim Ali_Num$

Dim Num%

If ActiveSheet.CheckBox1.Value = True Then

'***************************

Ali_Num = InputBox("إدخل عدد نسخ الطباعه", "منتدى أوفسينا")

If Ali_Num = "False" Or Ali_Num = Cancel Then Exit Sub

On Error Resume Next

'***************************

For Num = 1 To Ali_Num

Activewindow.SelectedSheets.PrintOut

Next

'***************************

Exit Sub

Else

GoTo 1

End If

1:

If Range("i5") = "" Then

MsgBox ("ادخل رقم الفاتوره")

Exit Sub

Else

m = ActiveWorkbook.Name

Workbooks.Add

N = ActiveWorkbook.Name

Windows(m).Activate

ActiveSheet.Range("b1:j23").Copy

Windows(N).Activate

ActiveSheet.Range("b1:j23").Select

ActiveSheet.Paste

  Range("b1:j23").Select

    Selection.Copy

Range("b1:j23").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

	    :=False, Transpose:=False

Columns("b:J").EntireColumn.AutoFit

Range("b1").Select

Application.CutCopyMode = False

Application.DisplayAlerts = False

If aah = [I5] & ".xls" Then

MsgBox "الملف موجود بالفعل..."

ActiveWorkbook.Close

Application.DisplayAlerts = True

Exit Sub

Else

'*************************************************

ActiveWorkbook.SaveAs Filename:=Path_x & m_r & Fom_n

'*************************************************

Application.DisplayAlerts = True

ActiveWorkbook.Close

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

End If

End If

End Sub

وهكذا للمقبوضات

Public Nm_Work As String

Private Const Path_A2 As String = "D:\المبيعات\فواتير\مقبوضات العملاء\"

Public Sub Ali_Proceed()

' 1 = مسار الملف المحدد أعلى الكود

' 2 = تحديد خلية التي بها رقم المستند

' 3 = حفظ الملف بأسم

Nm_Work = "  مقبوضات"

save_file Path_A2, [I5], Nm_Work

End Sub

Public Sub save_file(Path_x As String, m_r As Range, ByVal Fom_n As String)

Dim full_path As String

Dim aah As String

Dim Ali_Num$

Dim Num%

If ActiveSheet.CheckBox1.Value = True Then

'***************************

Ali_Num = InputBox("إدخل عدد نسخ الطباعه", "منتدى أوفسينا")

If Ali_Num = "False" Or Ali_Num = Cancel Then Exit Sub

On Error Resume Next

'***************************

For Num = 1 To Ali_Num

Activewindow.SelectedSheets.PrintOut

Next

'***************************

Exit Sub

Else

GoTo 1

End If

1:

If Range("i5") = "" Then

MsgBox ("ادخل رقم الفاتوره")

Exit Sub

Else

m = ActiveWorkbook.Name

Workbooks.Add

N = ActiveWorkbook.Name

Windows(m).Activate

ActiveSheet.Range("b1:j23").Copy

Windows(N).Activate

ActiveSheet.Range("b1:j23").Select

ActiveSheet.Paste

  Range("b1:j23").Select

    Selection.Copy

Range("b1:j23").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

	    :=False, Transpose:=False

Columns("b:J").EntireColumn.AutoFit

Range("b1").Select

Application.CutCopyMode = False

Application.DisplayAlerts = False

If aah = [I5] & ".xls" Then

MsgBox "الملف موجود بالفعل..."

ActiveWorkbook.Close

Application.DisplayAlerts = True

Exit Sub

Else

'*************************************************

ActiveWorkbook.SaveAs Filename:=Path_x & m_r & Fom_n

'*************************************************

Application.DisplayAlerts = True

ActiveWorkbook.Close

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

End If

End If

End Sub

  • Like 1
رابط هذا التعليق
شارك

الاستاذ الفاضل ابو نصار حفظكم الله ورعاكم وكثر من امثالكم

علما وخلقا ونكرانا للذات

حقيقي انا خجلانه من سمو خلقكم وتعبكم معي

ابقاك الله ذخرا للمنتدي وزادك علما وايمانا

تم المطلوب كاملا والحمد لله

لكم ايها الاستاذ المبجل ومن خلالكم شكري الجزيل للاستاذ ابو حنين

حيث ساعدتموني مساعدة لن انساها

دمتم دائما بخير

وبارك الله بكم

مع خالص تقديري

اختكم في الله سالي انور

رابط هذا التعليق
شارك

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information