تعديل في الكود ليصل إلى أبعد مدى ومن الأفضل آخر سطر فيه بيانات

[hicham2610]

السلام عليكم

توصلت لإنجاز هذا البرنامج عبر تسجيل الماكرو

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

طريقة الاشتغال:يفتح AO و CT و prog والضغط على الزر في الورقة الأولى من prog

المرجو من الإخوة الكرام

التعديل على الكود الموجود في الزر لكي يكون مختصرا والأهم: ليشمل آخر سطر فيه بيانات لكي يكون صالحا مستقبلا لإشتغال على اي ملفات اخرى غير هذه

وشكرا جزيلا

من فضلك لا تكرر نفس المشاركات والا ستحذف جميع المشاركات

2.rar

[omar elhosseini]

مرحبا

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

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

وسأقوم بتتبع خطواتك المرتبة وتنفيذها

فأحسن ورتب الخطوات جيدا حتي استطيع مساعدتك

تحياتي لك

[hicham2610]

جزاك الله خيرا أخي الكريم

ملف prog فيه زر يشتغل على الملفين المرفقين CT و AO لكن بهذه الوضعية

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

بحيث يصبح صالحا للاشتغال على ملفات أخرى ويكون المحدد هو الذهاب لغاية آخر سطر فيه بيانات

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

بالنسبة لاختصار الكود توصلت ب:الكود في المرفقات

Sub Macro1()
Dim F As FileDialog
Dim Doc1 As String, Doc2 As String
Dim WB1 As Workbook, WB1SH As Worksheet
Dim WB2 As Workbook, WB2SH As Worksheet, WB2Nom
Dim WB3 As Workbook, WB3SH As Worksheet, WB3Nom

Set WB1 = ThisWorkbook
Set WB1SH = WB1.Worksheets("Feuil2")
MsgBox "Merci d'ouvrir le fichier C.T AO", vbInformation, "HICHAM"
Set F = Application.FileDialog(msoFileDialogOpen)
With F
    F.Title = "Merci d'ouvrir le fichier C.T AO"
    .AllowMultiSelect = False
    .Filters.Add "Fichiers Excel", "*.xlsx", 1
    .Show
    On Error Resume Next
    F.Execute
    If Err <> 0 Then
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0
    Set WB2 = ActiveWorkbook
End With
UserForm1.Show
Set WB2SH = ActiveSheet

MsgBox "Merci d'ouvrir le fichier AO", vbInformation, "HICHAM"
Set F = Application.FileDialog(msoFileDialogOpen)
With F
    F.Title = "Merci d'ouvrir le fichier AO"
    .AllowMultiSelect = False
    .Filters.Add "Fichiers Excel", "*.xlsx", 1
    .Show
    On Error Resume Next
    F.Execute
    If Err <> 0 Then
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0
    Set WB3 = ActiveWorkbook
End With
UserForm1.Show
Set WB3SH = ActiveSheet

WB3SH.Cells.Copy WB1SH.Range("A1")
WB1.Worksheets("Feuil2").Rows("9:150").RowHeight = 15
WB2SH.Range("F7:F150").Copy
WB1SH.Range("G9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("G7:G150").Copy
WB1SH.Range("J9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("H7:H150").Copy
WB1SH.Range("M9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("I7:I150").Copy
WB1SH.Range("P9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("J7:J150").Copy
WB1SH.Range("S9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("K7:K150").Copy
WB1SH.Range("V9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("L7:L150").Copy
WB1SH.Range("Y9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("M7:M150").Copy
WB1SH.Range("AB9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB1SH.Range("I9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-3]*RC[-1],"""")"
WB1SH.Range("I9").AutoFill Destination:=WB1SH.Range("I9:I78"), Type:=xlFillDefault
WB1SH.Range("I9:I78").Select
WB1SH.Range("I9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-3]*RC[-1],"""")"
WB1SH.Range("L9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-6]*RC[-1],"""")"
WB1SH.Range("L9").AutoFill Destination:=WB1SH.Range("L9:L78"), Type:=xlFillDefault
WB1SH.Range("L9:L78").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-6]*RC[-1],"""")"
WB1SH.Range("O9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-9]*RC[-1],"""")"
WB1SH.Range("O9").AutoFill Destination:=WB1SH.Range("O9:O78"), Type:=xlFillDefault
WB1SH.Range("O9:O78").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-9]*RC[-1],"""")"
WB1SH.Range("R9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-12]*RC,"""")"
WB1SH.Range("R9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-12]*RC,"""")"
WB1SH.Range("R9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-12]*RC[-1],"""")"
WB1SH.Range("R9").AutoFill Destination:=Range("R9:R78"), Type:=xlFillDefault
WB1SH.Range("U9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-15]*RC[-1],"""")"
WB1SH.Range("U9").AutoFill Destination:=Range("U9:U78"), Type:=xlFillDefault
WB1SH.Range("X9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-18]*RC[-1],"""")"
WB1SH.Range("X9").AutoFill Destination:=Range("X9:X78"), Type:=xlFillDefault
WB1SH.Range("AA9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-21]*RC[-1],"""")"
WB1SH.Range("AA9").AutoFill Destination:=Range("AA9:AA78"), Type:=xlFillDefault
WB1SH.Range("AD9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-24]*RC[-1],"""")"
WB1SH.Range("AD9").AutoFill Destination:=Range("AD9:AD78"), Type:=xlFillDefault
End Sub

 

تم تعديل يناير 24, 2020 بواسطه hicham2610

[omar elhosseini]

اخي ليس هذا ما اقصد

الكود طويل علي التتبع

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

لان الموضوع والكود غير مفهوم لي

احكي لي هكذا بعيدا عن الاكسيل مثلا :

1- افتح ملف AO

2- انسخ اول شيت  الي ورقة جديدة في ملف prog

3-  افعل كذا

4-- افعل كذا

هكذا اخي حتي اساعدك

 

[hicham2610]

السلام عليكم

بالنسبة للكود التالي:

Range("I7:I150").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("prog.xlsm").Activate
    Range("P9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

كيف أعدل ليصل إلى آخر سطر فيه بيانات هل فقط ب 

Range("I7:I7").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("prog.xlsm").Activate
    Range("P9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

أم من الأفضل وضع مثلا5000

Range("I7:I5000").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("prog.xlsm").Activate
    Range("P9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

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

[omar elhosseini]

تفضل اخي

 

 

 

Cel to end data.xls

[omar elhosseini]

استخدم هذا الجزء من الكود 

وهو يفتح ملف AO

وينسخ اول وررقة منه الي ورقة جديدة في نهاية ملف prog

ثم يغلق ملف AO

لاحظ اسم ملف AO مكتوب في الخلية F1

 

 

book1.xls

[hicham2610]

السلام عليكم

لكي يعمل معي البرنامج لغاية آخر سطر فيه بيانات لم أعرف الطريقة واحطياطا برمجته على 5000 لمن يعرف الطريقة يمكنه أن يعدل في الملف ليعمل ليصل إلى آخر سطر فيه بيانات مهما كان الملف

والمشكلة أن أثر الأسطر الزائدة تظهر في الأسفل فارغة 

كيف أعدل لحذف الأسطر الفارغة أو العمل منذ البداية على آخر سطر فيه بيانات لأن الملفات المشتغل عليها تختلف مرة عن أخرى وغير محددة يمكن أن تصل إلى 3000 سطر أو أكثر

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

 

بالعربية.rar

[omar elhosseini]

الكود السابق

استبدل

Ext = ".xls"

ب

Ext = ".xlsx"

 

[hicham2610]

جزاك الله خيرا وأحسن إليك