personel.xlb içerisinde bir den fazla makro birleştirme ve kısayol atama

[mustilem23]

Merhaba,

Personel.xlb dosyamın içerisine günlük kullanmış olduğum makroları birleştirip 3 ü için ayrı klavye kısayolu eklemek mümkün müdür çok sık kullanıyorum yardımcı olabilirseniz çok makbule geçecek.


ctr+alt+w

Public Sub CloseAllWorkbooks()
Dim wb As Workbook
For Each wb In Workbooks
If UCase(wb.Name) <> "PERSONAL.XLSB" Then wb.Close False
Next wb
End Sub

ctr+alt+q

Sub Birleştir()

Dim Syf As String, _
i As Long, _
EH As String, _
Kodlar

Syf = ActiveSheet.Name

EH = MsgBox(Syf & " SAYFASINDA KODLARI BİRLEŞTİRECEĞİM, EMİN MİSİNİZ?", vbYesNo, "SORGULAMA")
If EH = vbNo Then Exit Sub

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Application.CutCopyMode = False
End With

Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "XX"

Sheets(Syf).Range("A:A").Copy Range("A1")
i = Cells(Rows.Count, "A").End(3).Row

ActiveSheet.Range("$A$1:$A$" & i).RemoveDuplicates Columns:=1, Header:=xlYes

For i = 3 To Cells(Rows.Count, "A").End(3).Row
If Kodlar = "" Then
Kodlar = Cells(i, "A")
Else
Kodlar = Kodlar & ";" & Cells(i, "A")
End If
Next i

Sheets(Syf).Select
Range("L2") = Kodlar
Sheets("XX").Delete

With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Application.CutCopyMode = True
End With

End Sub

Private Sub Workbook_Open()

Application.CommandBars("Cell").Reset

Dim menü_ekle As CommandBarControl
Set menü_ekle = Application.CommandBars("Cell").Controls.Add
With menü_ekle
.Caption = "Bul23"
.OnAction = "BuçalışmaKitabı.Bul23"
End With

End Sub
Sub Bul23()
Range("A1").Select
Range("A:IV").Interior.ColorIndex = xlNone
ad = InputBox("aranacak değeri yazınız.", "DEĞER", "")
If ad = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
sat = 0
yer = ""
With Range("A:IV")
Set d = .Find(ad, LookIn:=xlFormulas, LookAt:=xlPart) 'Hücreye göre arar
'Set d = .Find(ad, LookIn:=xlValues, LookAt:=xlWhole) 'Kelimeye göre arar
If Not d Is Nothing Then
FirstAddress = d.Address
Do
d.Interior.ColorIndex = 3
d.Select
If yer <> "" Then
ekle = ","
Else
ekle = ""
End If
yer = yer & ekle & d.Address(False, False)
yer1 = yer1 & d.Address(False, False) & Chr(10)
sat = sat + 1
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With
If sat = 0 Then
MsgBox ad & " değeri bulunamamıştır"
Exit Sub
End If
Range(yer).Select
MsgBox yer1 & Chr(10) & sat & " adet bulundu", vbInformation, "Hücrelerin numaraları"


End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim r
For r = 1 To Application.CommandBars("Cell").Controls.Count
'MsgBox Application.CommandBars("Cell").Controls(r).Caption
If Application.CommandBars("Cell").Controls(r).Caption = "Bul23" Then
Application.CommandBars("Cell").Controls(r).Delete
End If
Next


End Sub

 

[mustilem23]

arkadaşlar 3 makro birleştirilebilir mi yardımcı olabilir misiniz rica etsem.