الـعيدروس

السلام عليكم
 
شاهد المرفق
 
NDT Reporting_A.rar

السلام عليكم
 
جرب هكذا
Public Sub Ali() With Sheet4 [C7:Av50] = Empty .Range("D4:Av50").Value = Application.Trim(.Range("D4:Av50").Value) For C = 4 To 50 For Each R In .Range("D" & C & ":AV" & C) If R <> "" And R = [I2] Then Rr = Cells(Rows.Count, R.Column).End(xlUp).Offset(1, 0).Row Cells(Rr, R.Column - 1).Value = R.Value Cells(Rr + 1, R.Column - 1).Value = .Cells(R.Row, 2).Value End If Next Next End With End Sub

السلام عليكم
 
جرب المرفق
وتأكد من النتائج 
 
تحياتي
Profseer_v3.3.rar

السلام عليكم
 
اخي الفاضل اسلام
حسب فهمي لطلبك
تريد تحويل الجداول الى نطاق وليس حذفهم ؟
 
إستخدم الكود التالي :
Public Sub Ali_Tab() Dim Sht As Worksheet Dim Tb As ListObject Dim r_Tb As Range On Error Resume Next For Each Sht In ThisWorkbook.Worksheets For Each Tb In Sht.ListObjects With Tb Set r_Tb = .Range .Unlist With r_Tb .Interior.ColorIndex = xlColorIndexNone .Font.ColorIndex = xlColorIndexAutomatic .Borders.LineStyle = xlLineStyleNone End With End With Next Tb Next Sht On Error GoTo 0 End Sub

السلام عليكم
 
شاهد الشرح بالمرفق
شرح_تنسيق.rar

السلام عليكم
 
جرب المرفق
9-2013_A.rar

السلام عليكم
 
Classeur1_A.rar

Public Sub Ali_Copy() Dim F, Fn, Nm, wb As Workbook Dim Dir_w, Chk$ '********************************** ' مسار مجلد ملفات الإكسل Dir_w = "C:\Users\gh\Desktop\delet" '********************************** Th = ThisWorkbook.Name C = 1 Set F = CreateObject("Scripting.FileSystemObject") Set Fn = F.GetFolder(Dir_w) For Each Fn In Fn.Files If Mid(Fn.Name, InStrRev(Fn.Name, ".") + 1) = "xls" Then Chk = Dir_w & Application.PathSeparator & Fn.Name If Wr_open(Chk) = False Then On Error Resume Next Application.ScreenUpdating = False Application.DisplayAlerts = False Workbooks.Open Chk Application.ScreenUpdating = True Application.DisplayAlerts = True On Error GoTo 0 End If End If Next Fn For wr = 1 To Workbooks.Count If Workbooks(wr).Name <> Th Then Workbooks(wr).Worksheets(1).Range("A2:A100").Copy Workbooks(Th).Activate Cells(1, C) = Workbooks(wr).Name Cells(2, C).PasteSpecial xlPasteValues C = C + 1 End If Next End Sub Function Wr_open(Wn As String) As Boolean Dim Wbook As Workbook On Error Resume Next Set Wbook = Workbooks(Wn) Wr_open = Not Wbook Is Nothing On Error GoTo 0 End Function

السلام عليكم
 
 
الرجاء انشاء موضوع منفصل للطلب كي يسهل البحث للاعضاء
مع ارفاق مثال وبه الكود
والحل موجود ان شاء الله

السلام عليكم
 
اضفظ التالي في حدث الفورم
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then MsgBox "إستخدم زر خروج", vbCritical, "" Cancel = True End If End Sub

بامكانك تعديل مسمى الورقة
او ينفذ الكود على الورقة الفعاله
With ActiveSheet بدلا من 
With Sheet1

السلام عليكم

تفضل


Public Declare Sub Sleep Lib "kernel32" (ByVal A_Scound As Long) Public Sub Ali_API() DoEvents '1000 ' إنتظار ثانية ' 500 ' إنتظار نصف ثانية وهكذا Sleep (500) Ali_Time Exit Sub End Sub Private Sub Ali_Time() MsgBox "مرحباً", vbExclamation, "منتدى أوفسينا" End Sub

السلام عليكم
اضافة الى حل الاستاذ القدير يجياوي

اخي باسم بالامكان تشغيل زر الادخال بإختصار معين مثلا
ALT+d
فليكن اسم الزر CommandButton1 والاختصار ALT+D

Private Sub UserForm_Initialize() CommandButton1.Accelerator = "d" End Sub وداخل كود الزر تحط هذا السطر Me.CommandButton1.Default = True

بمعنى تضغط اختصار ALT+ حرف D
راح يعمل عمل الزر
ارجو ان يكون وضحت الفكرة
تحياتي