Otomatik Çift tıklama kodu başka pc de hata veriyor

[kkkazan]

Merhabalar ,

Size aşağıda sunduğum kod sayfa 1 deki veriyi seçip butona bastığımda sayfa 2 ye belirlenen dizilime göre kopyalama yapıyor son olarak Now(tarih ve saat) atamasını ayırmak sadece tarihi koymak için bir kod ekledim. fakat bu seferde tarih formatında değilde 01.01.2019 şeklinde görünüyor halbuki ben süzgeçte tarih sıralamasında +2019 > +Ocak gibi kırılımlarını görmek istiyordum bunun için de en alttaki Range (R:R) ile başlayan kodu ekledim yani hücresine otomatik çift tıklama yapsın ki o hali alsın. Kendi laptopumda çalışıyor fakat başka PC de Compile error in hidden module : Module 7 This error commonly occurs when code is incompatible with the version platform or architecture of this application Click help for information on how to correct this error. şeklinde hata aldım. Bu kodun diğer bilgisarda çalışması için ne yapabilirim ?

Sub aktar()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim S1 As Worksheet, S2 As Worksheet, Son As Long
Set S1 = Sheets("AramaLıst")
Set S2 = Sheets("VERI")
S1.Select
If ActiveCell.Column = 1 Then
S1.Cells(ActiveCell.Row, 1).Copy
Son = S2.Cells(S2.Rows.Count, 1).End(3).Row + 1
S2.Range("A" & Son).PasteSpecial xlPasteAll
S2.Range("L" & Son) = 1
S2.Range("R" & Son) = Now ' tarih ve saat olarak atıyor'
End If
Worksheets("VERI").Activate
For i = 2 To Cells(Rows.Count, "R").End(3).Row ' tarih ve saati ayırmak için kullandım'
Cells(i, "R") = Left(Cells(i, "R"), 11)
Next i
Range("R:R").TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _ ' kalan tarih hücresini otomatik çift tıklama ile normale döndürmek için kullandım'
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 4), TrailingMinusNumbers:=True

Application.ScreenUpdating = True

End Sub

 

[Korhan Ayhan]

Now yerine Date yazarak deneyin.

Ek olarak alta eklediğiniz tarih saat ayırma döngüsünü kaldırın.

Bu düzeltmeden sonra kodu diğer PC'de F8 tuşu ile adım adım çalıştırın. Hangi satırda hata veriyorsa onu forumda belirtin. Yardımcı olmaya çalışalım.

 

[YUSUF44]

Ek olarak makroyla bir hücreye tarih ve/veya saat eklediğinizde biçimi doğru görünmüyorsa ya o hücrelerin biçimini kendiniz ayarlayın ya da makroya biçim ayarlama kodu ekleyin. Left/Right/Mid gibi komutlar veriyi metin formatına çevirdiği için istediğiniz işleme uygun değiller.

 

[kkkazan]

Merhaba,

Aynı sayfada çift tıklama makrosunu için iki farklı işlemde uygulama yapabilirmiyim? 1.işlem benim için sorunsuz çalışıyor fakat 2.işlem ters tıklama ile takvim sekmesi açılıyor ve sadece o hücrede takvim çalışmasına izin veriyor , kopyalanmış Takvim uygulaması dışında benimde oluşturmuş olduğum Userform2 var yani takvim. işlem 2 de her hücreye tarih atayabileceğim userform2 yi sadece (S ) sutunun daki herhangi bir hücreye çift tıkladığımda açılsın ve istediğim ve üzerinde tıkladığım herhangi bir hücreye tarih ataması yapabilsin istiyorum. Yani 1 deki ve 2 deki çifttıklama farklı işlemleri kabul etsin istiyorum.

Kod aşağıdaki gibi
1- çift tıkladığında kopyala yapıştır benim için sorun suz çalışıyor.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("V:Z")) Is Nothing Then Exit Sub
Target.Value = Cells(Target.Row, "U").Value
Application.CommandBars("Cell").Reset
If Intersect(Target, [R:S]) Is Nothing Then Exit Sub
Call ac

End Sub
----------------------------------------------------------------------------------------------------------
2- Bu işlem forumlarınızdan kendi çalışma tabloma eklendi.Diğer eklentileriyle birlikte sorunsuz çalışıyor. Fakat sağ klik yada tek hücreye hizmet versin istemiyorum.

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Application.CommandBars("Cell").Reset
If Intersect(Target, [S:S]) Is Nothing Then Exit Sub
For a = Application.CommandBars("Cell").Controls.Count To 1 Step -1
Application.CommandBars("Cell").Controls(a).Delete
Next
Set menu01 = Application.CommandBars("Cell").Controls.Add
With menu01
.Caption = "TAKVİM AÇ"
.OnAction = "ac"
End With
Exit Sub
menu
End Sub

 

[kkkazan]

Bu arada 1.işlemde alttaki kodu yanlışlıkla eklemişim. onu saymayın lütfen

Application.CommandBars("Cell").Reset
If Intersect(Target, [R:S]) Is Nothing Then Exit Sub
Call ac

 

[YUSUF44]

Aşağıdaki gibi dener misiniz?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("V:Z")) Is Nothing Then goto 10
Target.Value = Cells(Target.Row, "U").Value
10:
Application.CommandBars("Cell").Reset
If Intersect(Target, [S:S]) Is Nothing Then Exit Sub
For a = Application.CommandBars("Cell").Controls.Count To 1 Step -1
Application.CommandBars("Cell").Controls(a).Delete
Next
Set menu01 = Application.CommandBars("Cell").Controls.Add
With menu01
.Caption = "TAKVİM AÇ"
.OnAction = "ac"
End With
Exit Sub
menu
End Sub

 

[kkkazan]

Teşekürler ufak bir değişiklik yaptım aşağıdaki kodu kullandım güzel çalışıyor
'GoTo 10 '
10:
detaylar herşeydir

 

[YUSUF44]

goto ifadesini GoTo olarak çevirmeyi diyorsanız vba kendiliğinden çeviriyor bildiğim kadarıyla.

 

[kkkazan]

yo yo onda sorun yok tüm kodda değişiklik yaptım anlamında ama goto işime yaradı demek istedim.

Başka bir konu geldi şimdi önüme F2+Enter Kodu çalışıyor ama dosyayı açıpta ilk yaptığım aktarmada numlock tuşlarımı yön tuşuna dönüştürüyor. sonraki aktarmada düzeliyor. ne yapabilirim. ??

Sub AKTAR()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim S1 As Worksheet, S2 As Worksheet, Son As Long
Set S1 = Sheets("AramaLıst")
Set S2 = Sheets("VERI")
S1.Select
If Activecell.Column = 1 Then
S1.Cells(Activecell.Row, 1).Copy
Son = S2.Cells(S2.Rows.Count, 1).End(3).Row + 1
S2.Range("A" & Son).PasteSpecial xlPasteAll
S2.Range("L" & Son) = 1
S2.Range("R" & Son) = Now
End If
Worksheets("VERI").Activate
S2.Range("R" & Son) = Left(S2.Range("R" & Son), 10)
S2.Range("R" & Son).Select
Application.SendKeys "{F2}"
Application.SendKeys "{ENTER}"
DoEvents
Application.ScreenUpdating = True

End Sub

 

[kkkazan]

Sonrasında düzelmiyormuş her aktarma da bir kapanıyor Num Lock bir açılıyor nasıl başarmış olabilirim??

 

[YUSUF44]

Sanıyorum, soldan 10 karakteri alıp sonra da sayıya dönüştürmeye çalışıyorsunuz. Eğer öyleyse:

S2.Range("R" & Son) = Left(S2.Range("R" & Son), 10)
S2.Range("R" & Son).Select
Application.SendKeys "{F2}"
Application.SendKeys "{ENTER}"

yerine

S2.Range("R" & Son) = Left(S2.Range("R" & Son), 10)*1

Şeklinde dener misiniz?

Ancak kodlarda numlock'la ilgili bir şey göremedim, belki dosyanızda bu işlemi yapan başka bir kod vardır.

 

[kkkazan]

S2.Range("R" & Son) = Left(S2.Range("R" & Son), 10)*1 buda olmadı bu F2+Enter komutunda sorun var gibi kaldırdığımda yapmıyor aşağıdaki kodu girdiğimde her kayıt atışımda bir numlock düzeliyor bidaha attığımda kapanıyor. Yaptığım işlem aslında Now komutunda saat geliyor ben ise saatsiz bir tarih atmaya çalışıyorum. Date() yada Today() komutlarını çalıştıramadım. Now () komutunda gelen saati kestiğimde ise tarih formatında kalmıyor onuda F2+Enter la düzeltiyorum fakat günün sonunda Numlock sorunu çıkıyor.

SendKeys "{F2}"
SendKeys "{ENTER}"
DoEvents

 

[YUSUF44]

Yapmak istediğiniz işlem excel mantığına biraz ters. saat ve tarih verisi excelde ondalıklı sayı olarak kaydedilir. tarih ve saat yazılı bir hücrenin biçimini genel yaparsanız bu durumu görebilirsiniz. Dolayısıyla ayırma işlemi belirttiğiniz şekilde olmaz.

Date() değil de sadece Date denediniz mi?

bu da yeterli değilse artık örnek dosya paylaşmanızın vakti gelmiştir.

 

[kkkazan]

ilginçtir daha önce denedim ben date i çalışmamıştı )))) demem o ki date is ok))

 

[kkkazan]

Bol Bol Teşekkürler

 

[htsumer]

Aynı şey bende de oluyor

Range("AJ4").Select
SendKeys "{F2}"
SendKeys "{ENTER}"

bu kodla rilk çalıştığında Numlock tuşu kapanıyor.

 

[Korhan Ayhan]

Linki inceleyiniz.

https://www.excel.web.tr/threads/numlock-tusunun-kapanmasi.173282/

 

[htsumer]

Teşekkür ederim..

 

[htsumer]

Linki inceleyiniz.

https://www.excel.web.tr/threads/numlock-tusunun-kapanmasi.173282/

EVet konuya baktım ama o kod kapalıyken açıyor, açıkken kapatıyor. Benim yukardaki kodlar açık olanı kapatoyor. Şu kodu refize edebilirmiyiz.

Sub num()
 If NumLock = False Then CreateObject("Wscript.Shell").SendKeys "{NUMLOCK}" 'NUMLOCK AÇAR
End Sub

Eğer numlock kapalıysa aç, açıksa bırak öyle kalsın gibilerden..