Excel Vba Code

[Yasser Fathi Albanna]

Remove Hyperlinks

Sub Remove_Hyperlinks()
If TypeName(Selection) <> "Range" Then Exit Sub
Application.ScreenUpdating = False
Selection.Hyperlinks.Delete
Application.ScreenUpdating = True
End Sub

Delete Empty Rows

Sub Del_Empty_Rows()
Dim R As Long
Dim rng As Range
Application.ScreenUpdating = False
 
If Selection.Rows.Count > 1 Then
   Set rng = Selection
Else
   Set rng = ActiveSheet.UsedRange.Rows
End If
 
For R = rng.Rows.count To 1 Step -1
   If WorksheetFunction.CountA(rng.Rows(R).EntireRow) = 0 Then
      rng.Rows(R).EntireRow.Delete
   End If
Next R
 
Application.ScreenUpdating = True
End Sub

Paste Values in Selected Cells

Sub Paste_Values()
Application.ScreenUpdating = False
 
With Selection
   .Copy
   .PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, _
  Transpose:=False
End With
 
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Convert phone numbers

Sub Convert_Phone()
Application.ScreenUpdating = False
'
' first highlight the cells you want to scrub
'
With Selection.SpecialCells(xlConstants)
   .Replace what:=Chr(160), Replacement:="", LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=True
   .Replace what:=Chr(32), Replacement:="", LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=True
   .Replace what:=")", Replacement:="", LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=True
   .Replace what:="(", Replacement:="", LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=True
   .Replace what:="-", Replacement:="", LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=True
   .Replace what:="+", Replacement:="", LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=True
End With
 
' at this point you could do one of two things:
' 1. do a "virtual" format where you just make the cell *appear* to be a
' phone number.
' Selection.NumberFormat = "(###) ###-####"
 
' 2. We can actually insert the parentheses and dash in the appropriate place.
'
' For each cell in Selection
'  cell = "(" & Left(cell, 3) & ") " & Mid(cell, 4, 3) & "-" & Right(cell, 4)
' Next cell
'
' uncomment whichever one you want!
'
'
Application.ScreenUpdating = True
End Sub

Fix Badly Imported Formulas

Sub FixFormulas()
Dim arrData() As Variant
Dim rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long
 
' let's not accidently use this on a non-Range object
If TypeName(Selection) <> "Range" Then Exit Sub
 
lRows = Selection.Rows.Count
lCols = Selection.Columns.Count
 
ReDim arrData(1 To lRows, 1 To lCols)
 
Set rng = Selection
arrData = rng.Value
 
For j = 1 To lCols
  For i = 1 To lRows
    arrData(i,j) = "=" & Right(arrData(i,j), Len(arrData(i,j)) - 1)
 Next i
Next j
 
rng.Value = arrData
 
Set rng = Nothing
End Sub

Rename Worksheet

Sub Rename_Sheet()
Dim workbookName As String
  workbookName = ActiveWorkbook.Name
  If Len(workbookName) > 26 Then Exit Sub
  workbookName = Left(workbookName, Len(workbookName) - 4)
  Sheets(1).Name = workbookName
End Sub

List workbook defined names

Sub ShowNames()
' list workbook names on separate worksheet
Dim x As Worksheet
Set x = Worksheets.Add
 
Dim nm As Name
Dim i As Long
 
i = 1
 
For Each nm In Names
  Cells(i, 1) = nm.Name
  Cells(i, 2) = "'" & nm.RefersTo
  i = i + 1
Next nm
 
End Sub

تم تعديل فبراير 10, 2015 بواسطه Eng : Yasser Fathi Albanna

[ياسر خليل أبو البراء]

أخي الحبيب ياسر

يا ريت شرح للأكواد عشان الناس تستفيد .. والأفضل إنك ترفق ملف لكل كود وتشرح الهدف منه وكيفية الاستفادة منه

بارك الله فيك

[Yasser Fathi Albanna]

من عنيا يا أ / ياسر

إنت تأمر

سوف أكوم بشرح فائدة كل كود مع إرفاق مثال ولكن مش بنفس الترتيب بالمشاركة الأولى حتى يتم عمل مثال

فى البداية

كود Rename Worksheet

يقوم هذا الكود كما موضح بتسمية شيت 1 بنفس إسم ملف الإكسيل

يمكن تغيير الشيت المراد تسميته بنفس إسم ملف الإكسيل كما تريد

Sub Rename_Sheet()
Dim workbookName As String
  workbookName = ActiveWorkbook.Name
  If Len(workbookName) > 26 Then Exit Sub
  workbookName = Left(workbookName, Len(workbookName) - 4)
  Sheets(1).Name = workbookName
End Sub

شاهد المرفق وقم بالتجربة

Rename Worksheet.rar

[Yasser Fathi Albanna]

الكود الثانى

Delete Empty Rows

وهو يقوم بحذف الصفوف الفارغة ما بين البيانات المدونة بالشيت مع الحفاظ على الصفوف التى بها بيانات

Sub Del_Empty_Rows()
Dim R As Long
Dim rng As Range
Application.ScreenUpdating = False
 
If Selection.Rows.Count > 1 Then
   Set rng = Selection
Else
   Set rng = ActiveSheet.UsedRange.Rows
End If
 
For R = rng.Rows.Count To 1 Step -1
   If WorksheetFunction.CountA(rng.Rows(R).EntireRow) = 0 Then
      rng.Rows(R).EntireRow.Delete
   End If
Next R
 
Application.ScreenUpdating = True
End Sub

مرفق مثال للتجربة

Delete Empty Rows.rar

[Yasser Fathi Albanna]

هل هذا طلبك أستاذى الفاضل /  ياسر خليل

أم لحضرتك طلب أخر

أعزرنى فأنا لا أعرف كيفية الشرح على الكود نفسة

بقدر إستطاعتى أقوم بعمل مثال

[Yasser Fathi Albanna]

الكود الثالث

وهو يقوم بعمل إضافة لصفحة جديدة ( workbook ) كما تشاء من عدد الصفحات

Sub Del_Empty_Rows()
Dim R As Long
Dim rng As Range
Application.ScreenUpdating = False
 
If Selection.Rows.Count > 1 Then
   Set rng = Selection
Else
   Set rng = ActiveSheet.UsedRange.Rows
End If
 
For R = rng.Rows.Count To 1 Step -1
   If WorksheetFunction.CountA(rng.Rows(R).EntireRow) = 0 Then
      rng.Rows(R).EntireRow.Delete
   End If
Next R
 
Application.ScreenUpdating = True
End Sub

مرفق مثال

List workbook defined names.rar

تم تعديل فبراير 10, 2015 بواسطه Eng : Yasser Fathi Albanna

[ياسر خليل أبو البراء]

الأخ الفاضل ياسر

إليك تصحيح الكود في المشاركة رقم 6 حيث جربت الكود ولم يعمل

يقوم الكود بعمل قائمة بأسماء النطاقات الموجودة داخل المصنف في ورقة عمل جديدة

Sub ShowNames()
    Dim X As Worksheet
    Set X = Worksheets.Add
     
    Dim nm As Name
    Dim I As Long
     
    I = 1
    With ActiveSheet
        For Each nm In ThisWorkbook.Names
          .Cells(I, 1).Value = nm.Name
          .Cells(I, 2).Value = nm
          I = I + 1
        Next nm
        .Range("A1:B1").EntireColumn.AutoFit
    End With
End Sub

[محمد لطفى]

 

ويل ياويل