• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Eklenti ile özel menü

T

takirti

Katılım
29 Ekim 2006
Mesajlar
295
Excel Vers. ve Dili
OFİS 2003 Türkçe
İyi Akşamar Herkese
Makrolu dosyamı xla formatına çevirerek eklenti haleine getirdim. Böylece açılan her excel sayfasında makroyu kullanabiliyorum. Fakat eklentiyi kaldırmama rağmen menü eklentisi gitmedi. anlamadığım bir şekilde 6-7 adet menü (BİRLEŞTİR olarak)haline geldi eski haline getiremedim malesef. fikri olan varmı ek dosyada resmi var.
 

Ekli dosyalar

  • adsız.jpg
    adsız.jpg
    92.9 KB · Görüntüleme: 45
Araçlar>Eklentiler içinden ilgili eklentiyi kaldırdınız mı ?
 
eklentiyi kaldırmadım. eklentiyi kullanmak istiyorum. ama neden durduk yere 6 ya kadat aynı menü oluşuyor. onu anlamadım
 
Selamlar,

Resim yerine kullandığınız kodları verseydiniz daha hızlı yardım alabilirdiniz.
 
Korhan Ayhan' Alıntı:
Selamlar,

Resim yerine kullandığınız kodları verseydiniz daha hızlı yardım alabilirdiniz.
Genişletmek için tıkla ...

Sub auto_close()
Do
On Error Resume Next
Application.CommandBars.FindControl(Tag:="BİRLEŞTİR").Delete
Loop While Not Application.CommandBars.FindControl(Tag:="BİRLEŞTİR") Is Nothing

End Sub

Sub auto_open()
Application.StatusBar = " < Doğrudan Temin > İlçe Milli Eğitim Müdürlüğü : Maaş Hesap İhale Birimi Kurum Telefon: ............"

Call auto_close
Set anamenu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(msoControlPopup)
With anamenu
.Caption = "BİRLEŞTİR"
.Tag = "Etiket"
.BeginGroup = True
End With
Set digermenu = anamenu.Controls.Add(msoControlButton)
digermenu.Caption = "BAŞLA"
digermenu.OnAction = "BASLA" 'Bu alana Çalıştırmak istediğin makronun adını yaz.
'digermenu.FaceId = 16
digermenu.BeginGroup = True

End Sub
Sub BASLA()
Dim sat As Long, i As Long, myarr(), z As Object
Dim j As Byte, n As Long, list()
Sheets("Sayfa3").Select
Range("A4:E65536").ClearContents
Application.ScreenUpdating = False
ReDim myarr(1 To 5, 1 To 65536 * 2)
Set z = CreateObject("Scripting.Dictionary")
For j = 1 To 2
sat = Sheets(j).Cells(65536, "A").End(xlUp).Row
If sat > 2 Then
list = Sheets(j).Range("A3:G" & sat).Value
For i = 1 To UBound(list)
If Not z.exists(list(i, 1)) Then
n = n + 1
z.Add list(i, 1), n
myarr(1, n) = list(i, 1)
myarr(2, n) = list(i, 2)
End If
myarr(j + 2, z.Item(list(i, 1))) = myarr(j + 2, z.Item(list(i, 1))) + list(i, 7)
myarr(5, z.Item(list(i, 1))) = myarr(5, z.Item(list(i, 1))) + list(i, 7)
Next i
Erase list
End If
Next j
Set z = Nothing
If n > 0 Then
ReDim Preserve myarr(1 To 5, 1 To n)
Range("A4").Resize(n, 5) = Application.Transpose(myarr)
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
Erase myarr
Application.ScreenUpdating = True
End Sub
 
takirti' Alıntı:
Sub auto_close()
Do
On Error Resume Next
Application.CommandBars.FindControl(Tag:="BİRLEŞTİR").Delete
Loop While Not Application.CommandBars.FindControl(Tag:="BİRLEŞTİR") Is Nothing

End Sub

Sub auto_open()
Application.StatusBar = " < Doğrudan Temin > İlçe Milli Eğitim Müdürlüğü : Maaş Hesap İhale Birimi Kurum Telefon: ............"

Call auto_close
Set anamenu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(msoControlPopup)
With anamenu
.Caption = "BİRLEŞTİR"
.Tag = "Etiket"
.BeginGroup = True
End With
Set digermenu = anamenu.Controls.Add(msoControlButton)
digermenu.Caption = "BAŞLA"
digermenu.OnAction = "BASLA" 'Bu alana Çalıştırmak istediğin makronun adını yaz.
'digermenu.FaceId = 16
digermenu.BeginGroup = True

End Sub
Sub BASLA()
Dim sat As Long, i As Long, myarr(), z As Object
Dim j As Byte, n As Long, list()
Sheets("Sayfa3").Select
Range("A4:E65536").ClearContents
Application.ScreenUpdating = False
ReDim myarr(1 To 5, 1 To 65536 * 2)
Set z = CreateObject("Scripting.Dictionary")
For j = 1 To 2
sat = Sheets(j).Cells(65536, "A").End(xlUp).Row
If sat > 2 Then
list = Sheets(j).Range("A3:G" & sat).Value
For i = 1 To UBound(list)
If Not z.exists(list(i, 1)) Then
n = n + 1
z.Add list(i, 1), n
myarr(1, n) = list(i, 1)
myarr(2, n) = list(i, 2)
End If
myarr(j + 2, z.Item(list(i, 1))) = myarr(j + 2, z.Item(list(i, 1))) + list(i, 7)
myarr(5, z.Item(list(i, 1))) = myarr(5, z.Item(list(i, 1))) + list(i, 7)
Next i
Erase list
End If
Next j
Set z = Nothing
If n > 0 Then
ReDim Preserve myarr(1 To 5, 1 To n)
Range("A4").Resize(n, 5) = Application.Transpose(myarr)
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
Erase myarr
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...

auto close değiştirdim.

Dim Cmbr As CommandBar
For Each Cmbr In Application.CommandBars
On Error Resume Next
Cmbr.Reset
Next Cmbr

kodunu ekledim. şuan için çalışıyor..
 
Selamlar,

Sorun "auto_close" isimli makronuzdadır. Bu makronuzu aşağıdaki şekilde değiştirip denermisiniz.

"auto_open" isimli makronuzda yeni menü tag ismini "Etiket" olarak tanımlamışsınız. Fakat "auto_close" isimli makronuzda tag ismini "BİRLEŞTİR" olarak yazmışsınız. Doğal olarak kod aslında her dosya kapanışında yeni menüyü taglar eşleşmediği için silemiyor. Sürekli olarak menü artarak ekleniyor.

Kod: 
Sub auto_close()
    Do
    On Error Resume Next
    Application.CommandBars.FindControl(Tag:="[COLOR=red]Etiket[/COLOR]").Delete
    Loop While Not Application.CommandBars.FindControl(Tag:="[COLOR=red]Etiket[/COLOR]") Is Nothing
End Sub

Not: Mesajlarınıza kod eklerken [ code ]Kodlarınız...[ /code ] şeklinde yazarsanız düz metin özelliğinden kurtulacaktır. Bu şekilde uygularsanız bizlerde rahatlıkla inceleyebiliriz.

Mesajımda düzgün çıkması için "[ code ]" şeklinde yazdım siz uygularken boşlukları yazmayınız.
 
Not: Mesajlarınıza kod eklerken [ code ]Kodlarınız...[ /code ] şeklinde yazarsanız düz metin özelliğinden kurtulacaktır. Bu şekilde uygularsanız bizlerde rahatlıkla inceleyebiliriz.

Mesajımda düzgün çıkması için "[ code ]" şeklinde yazdım siz uygularken boşlukları yazmayınız.[/QUOTE]

Teşekkürler. Dediğiniz şekilde yaparım. Yardımlarınız için teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst