حسين مامون

ربما يكون المطلوب هو هذا الكود في حدث الشيت1
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target > 0 Then Target.Offset(, 1).Select End If End Sub  
منع ادخال في اي خلية فيها بيانات.xlsm

تفضل
 
القاعدة (1) (1).xlsm

Option Explicit Sub test() Dim x1, x2, lr1, lr2 Application.ScreenUpdating = False Range("f5:h100").ClearContents lr1 = Range("b" & Rows.Count).End(xlUp).Row lr2 = Range("e" & Rows.Count).End(xlUp).Row For x1 = 4 To lr1 For x2 = 5 To lr2 If Cells(x1, 2) = Cells(x2, 5) Then If Cells(x1, 3) = "A" Then Cells(x2, 6) = Cells(x2, 6) + 1 ElseIf Cells(x1, 3) = "B" Then Cells(x2, 7) = Cells(x2, 7) + 1 ElseIf Cells(x1, 3) = "C" Then Cells(x2, 8) = Cells(x2, 8) + 1 'ElseIf Cells(x1, 3) = "D" Then 'Cells(x2, 9) = Cells(x2, 9) + 1 ' 'ElseIf Cells(x1, 3) = "E" Then 'Cells(x2, 10) = Cells(x2, 10) + 1 ' 'ElseIf Cells(x1, 3) = "G" Then 'Cells(x2, 11) = Cells(x2, 11) + 1 End If End If Next Next Application.ScreenUpdating = True End Sub جرب المرفق 
كود حلقات تكرارية
 
01.xls

تقرير 8.xlsm

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

افتح الملف واغلق الفورم  وافتح ملف اخر محفوظ بامتداد xlsm واضغط Alt+f11 وستجد الملفين  ثم ادخل الى thisworkbook وعدل الكود
 

اتمنى ان يكون ما تريد في المرفق
واعتذر 
تجربة (2) (2).xlsm

يمكنك استعمال هذا الماكرو البسيط 
انسخه الى مديول واربططه بزر في شيت sadol1
 
Option Explicit Sub test() Dim SD1 As Worksheet Dim SD2 As Worksheet Dim lr1, lr2, lr3, lr4 Application.ScreenUpdating = False Set SD1 = Sheets("sadok1") Set SD2 = Sheets("sadok2") lr1 = SD1.Cells(Rows.Count, "b").End(3).Row lr2 = SD1.Cells(Rows.Count, "s").End(3).Row SD1.Range("b8:o" & lr1).Copy lr3 = SD2.Cells(Rows.Count, "b").End(3).Row + 1 SD2.Range("b" & lr3).PasteSpecial SD1.Range("s8:af" & lr2).Copy lr4 = SD2.Cells(Rows.Count, "s").End(3).Row + 1 SD2.Range("s" & lr4).PasteSpecial Application.CutCopyMode = False SD1.Range("b8:o10000").ClearContents SD1.Range("s8:af10000").ClearContents Application.ScreenUpdating = True End Sub  

جرب المرفق 
 
fathy www.xlsm

جرب التعديل 
المستخدم asd
كلمة السر 123
 
login __ (1).xlsm

كان عليك ارفاق ملف للعمل عليه 
جرب دوبل كليك في النطاق الملون بالاصفر
test.xlsm

غير الكود بهذا 
Sub COPIE_cop() Dim Nam Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False Nam = ThisWorkbook.Name & " " & Format(Now(), "dd mm yyyy hh mm ss") ' ThisWorkbook.SaveCopyAs Filename:="D:\copie\" & Nam & ".xlsx" ActiveWorkbook.SaveAs Filename:="D:\copie\" & Nam & ".xlsx", FileFormat:= _ xlOpenXMLWorkbook, CreateBackup:=False Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True MsgBox "Êã ÍÝÙ äÓÎÉ ÈÇÓã " & Nam & " ", vbInformation End Sub  

ربما هذا الكود يفي بالغرض
Sub test() Dim lr Dim x lr = Range("a" & Rows.Count).End(xlUp).Row Range("i3:i" & lr).Formula = "=SUMIF($B:$B,$A:$A,H:H)" Range("i3:i" & lr).Value = Range("i3:i" & lr).Value Range("k3:k" & lr).Formula = "=SUMIF($B:$B,$A:$A,J:J)" Range("k3:k" & lr).Value = Range("k3:k" & lr).Value Range("m3:m" & lr).Formula = "=SUMIF($B:$B,$A:$A,L:L)" Range("m3:m" & lr).Value = Range("m3:m" & lr).Value End Sub  

حسب مشاركتك تم عمل المطلوب 
السعر يظهر عند اختيار نوع
الاجمالي يظهر عند ادخال العدد
اجمالي المبلغ يظهر ايضا عند ادخال العدد
 
مغسلة المودة.xlsm

حسب طلبك هذا مرفق 
Entry form (2).xlsb

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

 

او استعن بهذا الماكرو
Sub SplitRow1() With ActiveWindow .SplitColumn = 0 .SplitRow = 1 End With ActiveWindow.FreezePanes = True End Sub  

ما عليك سوى تغيير سطر في الكود
السطر من
MsgBox driveObject.serialnumber الى
Range("a1") = driveObject.serialnumber وسينسخ في الخليةA1

عليكم السلام
عليك بوضع هذا الكود في جميع النسخ المحفوظة في حدث Open بحيث لما تفتح نسخة يتنفذ الكود
Private Sub Workbook_Open() Workbooks("فاتورة.xlsm").Save Workbooks("فاتورة.xlsm").Close End Sub

ادخل رقم البحث في textbox1 واضغط مفتاح Entr على لوحة المفاتيح
 
testefile.xlsm

المرفق
بحث في نفس الملف في كل الصفحات وترحيل الى شيت.xlsm

نمودج قريب للشرح في مشاركتك
اتمنى ان يساعدك في طلبك
m2000.xlsm

ربما يكون المطلوب
Sub creatB() Dim OBJECTfso Dim OBJECTfolder Dim OBJECTfils Dim ws As Worksheet Set ws = ActiveSheet ws.Range("a2:a100").ClearContents Set OBJECTfso = CreateObject("scripting.filesystemobject") Set OBJECTfolder = OBJECTfso.getfolder("C:\Users\pc\Desktop\med") ws.Cells(1, "a").Value = "the file founf in " & OBJECTfolder.Name & "Are" For Each OBJECTfils In OBJECTfolder.Files ws.Range("a" & Rows.Count).End(xlUp).Offset(1) = OBJECTfils.Name 1: Next Set OBJECTfolder = Nothing Set OBJECTfils = Nothing Set OBJECTfso = Nothing End Sub  

اخي الكريم 
طبيعي ان يعمل الكود خطا ادا غيرنا اسمه او مساره 
يمكنك تغيير اسم الملف ولكن يجب تغييره ايضا في الكود
تحياتي
او تغيير الاسطر الاولى في الكود الى ما يلي
ولك فيحالة التعامل مع اكثر من ملف ستكون مشاكل 
Dim ws As Worksheet Set ws = ActiveWorkbook.Sheets("invoice") Dim wss As Worksheet Set wss = ActiveWorkbook.Sheets("sheet1")  

بعد اذن الاستاذMohamed_Fouad 
واثراء للموضوع 
جرب المرفق
 
Bank Cheque.xlsm

تم تعديل الكود جرب ربما يكون ما تريد
Sub trheel() Dim cl As Range, i As Integer For i = 2 To 41 For Each cl In Range("G3:G" & [G10000].End(xlUp).Row) If cl.Value = Sheets(i).Name Then If cl.Offset(0, -6).Resize(1, 7).Interior.Color = &HC0FFFF Then GoTo 1 cl.Offset(0, -6).Resize(1, 7).Copy Sheets(i).Range("A" & Sheets(i).[A10000].End(xlUp).Row + 1) cl.Offset(0, -6).Resize(1, 7).Interior.Color = &HC0FFFF End If 1: Next Next End Sub