Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 20-02-2017, 08:18   #11
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,018
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Aşağıdaki kodları ThisWorkbook kod sayfasına yapıştır.


Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Dim Eski_Değer

Private Sub Workbook_Open()

kayıt = ThisWorkbook.Path & "\kayit.txt" ' işlemlerin kayıt altına alındığı dosya


If CreateObject("Scripting.FileSystemObject").FileExists(kayıt) = False Then
alan1 = RightPadChar(" Kullanıcı Adı", " ", 40) & "/"
alan2 = RightPadChar("Tarih", " ", 30) & "/"
alan3 = RightPadChar("Saat", " ", 30) & "/"
alan4 = RightPadChar("Sayfa Hücre Adresi", " ", 30) & "/"
alan5 = RightPadChar("Eski Deger", " ", 30) & "/"
alan6 = RightPadChar("Yeni Deger", " ", 30) & "/"

yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6
Open kayıt For Append As #1
Print #1, yaz
'Print #1, alan1 & alan2 & alan3
Close #1
End If


alan1 = RightPadChar(Application.UserName & " Kullanıcı giris yapti", " ", 40) & "/"
alan2 = RightPadChar(Format(Now, "dd.mm.yyyy"), " ", 30) & "/"
alan3 = RightPadChar(Format(Now, "hh:nn:ss"), " ", 30) & "/"
alan4 = RightPadChar("", " ", 30) & "/"
alan5 = RightPadChar("", " ", 30) & "/"
alan6 = RightPadChar("", " ", 30) & "/"

yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6
Open kayıt For Append As #1
Print #1, yaz
'Print #1, alan1 & alan2 & alan3
Close #1


End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

kayıt = ThisWorkbook.Path & "\kayit.txt"
alan1 = RightPadChar(Application.UserName & " Kullanicisi cikis yapti", " ", 40) & "/"
alan2 = RightPadChar(Format(Now, "dd.mm.yyyy"), " ", 30) & "/"
alan3 = RightPadChar(Format(Now, "hh:nn:ss"), " ", 30) & "/"
alan4 = RightPadChar("", " ", 30) & "/"
alan5 = RightPadChar("", " ", 30) & "/"
alan6 = RightPadChar("", " ", 30) & "/"

yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6
Open kayıt For Append As #1
Print #1, yaz
Close #1

ActiveWorkbook.Save
ThisWorkbook.Close savechanges:=False
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

kayıt = ThisWorkbook.Path & "\kayit.txt"

alan1 = RightPadChar(Application.UserName & " Kullanicisi kayıt yaptı", " ", 40) & "/"
alan2 = RightPadChar(Format(Now, "dd.mm.yyyy"), " ", 30) & "/"
alan3 = RightPadChar(Format(Now, "hh:nn:ss"), " ", 30) & "/"
alan4 = RightPadChar("", " ", 30) & "/"
alan5 = RightPadChar("", " ", 30) & "/"
alan6 = RightPadChar("", " ", 30) & "/"

yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6

Open kayıt For Append As #1
Print #1, yaz
Close #1

End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

On Error Resume Next
If kontrol = False Then

If Target.Count > 1 Then Exit Sub

alan1 = Application.UserName
alan2 = Format(Now, "dd.mm.yyyy")
alan3 = Format(Now, "hh:nn:ss")
alan4 = ActiveSheet.Name & "!" & Target.Address(1, 1)
alan5 = IIf(Eski_Değer = "", "Boş Hücre", Eski_Değer)
If Target = "" Then
alan6 = "Değer Silindi !"
ElseIf Target.HasFormula = True Then
alan6 = "'" & Target.Formula
Else
alan6 = Target
End If

alan1 = RightPadChar(alan1, " ", 40) & "/"
alan2 = RightPadChar(alan2, " ", 30) & "/"
alan3 = RightPadChar(alan3, " ", 30) & "/"
alan4 = RightPadChar(alan4, " ", 30) & "/"
alan5 = RightPadChar(alan5, " ", 30) & "/"
alan6 = RightPadChar(alan6, " ", 30) & "/"
yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6
kayıt = ThisWorkbook.Path & "\kayit.txt"

Open kayıt For Append As #1
Print #1, yaz
Close #1

End If
kontrol = False

End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
If Target.Count > 1 Then Exit Sub
If Target.HasFormula = True Then
Eski_Değer = "'" & Target.Formula
Else
Eski_Değer = Target
End If
kontrol = False
End Sub


Function RightPadChar(ByVal Astr As String, PadChar As String, stLen As Integer) As String
Dim AStrL As Integer
Astr = Trim(Astr)
AStrL = Len(Astr)
If AStrL < stLen Then
Astr = Astr + String(stLen - AStrL, PadChar)
Else
Astr = Mid$(Astr, 1, stLen)
End If
RightPadChar = Astr
End Function
Function LeftPadChar(ByVal Astr As String, PadChar As String, stLen As Integer) As String
Dim AStrL As Integer
Astr = Trim(Astr)
AStrL = Len(Astr)
If AStrL < stLen Then
Astr = String(stLen - AStrL, PadChar) + Astr
Else
Astr = Mid$(Astr, 1, stLen)
End If
LeftPadChar = Astr
End Function
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-02-2017, 10:49   #12
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,018
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Kayıtlı verileri txt uzantılı dosyadan excelle almak için kod;

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub CommandButton1_Click()

parametre = InputBox("Kayıtları okuyabilmeniz için giriş şifresini giriniz şifre ", "uyarı!")
If parametre <> "1234" Then
MsgBox "Yanlış şifre girdiniz"
Exit Sub
End If

'On Error Resume Next
kayıt = ThisWorkbook.Path & "\kayit.txt"
Open kayıt For Append As #1
Close #1

Open kayıt For Input As #1

Do While Not EOF(1)
Line Input #1, deg1

sat = sat + 1
deg2 = Split(deg1, "/")
k = 0
For i = 0 To UBound(deg2)
k = k + 1

If sat > 1 Then
If k = 2 Then
Cells(sat, k).Value = Format(Trim(deg2(i)), "dd.mm.yyyy")

ElseIf k = 3 Then
Cells(sat, k).Value = Format(Trim(deg2(i)), "hh:nn:ss")
Else
Cells(sat, k).Value = Trim(deg2(i))
End If
Else
Cells(sat, k).Value = Trim(deg2(i))
End If
Next i
Loop
Close #1


End Sub
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-02-2017, 14:53   #13
asas44
 
asas44 kullanıcısının avatarı
 
Giriş: 13/07/2013
Şehir: Fethiye
Mesaj: 66
Excel Vers. ve Dili:
2013 excel
Varsayılan

Halit bey elinize yüreğinize sağlık fevkalade olmuş Allah razı olsun eminim birçok kişiyede yarayacaktır. Son küçük bir detay eksikliği var oda satır silinip yada eklendiğinde de durumu yazsa harika olurdu size zahmet olmaz ise satır sütun durumunuda yazarsa çok süper olur. Tekrar emeğinize sağlık.

Bu mesaj en son " 20-02-2017 " tarihinde saat 19:28 itibariyle asas44 tarafından düzenlenmiştir....
asas44 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 01-03-2017, 07:28   #14
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,018
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Alıntı:
asas44 tarafından gönderildi Mesajı Görüntüle
Halit bey elinize yüreğinize sağlık fevkalade olmuş Allah razı olsun eminim birçok kişiyede yarayacaktır. Son küçük bir detay eksikliği var oda satır silinip yada eklendiğinde de durumu yazsa harika olurdu size zahmet olmaz ise satır sütun durumunuda yazarsa çok süper olur. Tekrar emeğinize sağlık.
Bu kod aktif sayfanın birinci satır son sütununa ve birinci sütun son satıra nokta (.) işareti koymakta satır ve sütun silindiğinde nokta işaretleri kaymış olacağından log kayıtı tutacaktır bunun yanında satır ekleme işlemi yapmıyacaktır.

kod:

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Dim Eski_Değer

Private Sub Workbook_Activate()

If Worksheets(ActiveSheet.Name).Cells(Rows.Count, 1).Value <> "." Then
Worksheets(ActiveSheet.Name).Cells(Rows.Count, 1) = "."
End If
If Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).Value <> "." Then
Worksheets(ActiveSheet.Name).Cells(1, Columns.Count) = "."
End If

End Sub

Private Sub Workbook_Open()

kayıt = ThisWorkbook.Path & "\kayit.txt" ' işlemlerin kayıt altına alındığı dosya

If CreateObject("Scripting.FileSystemObject").FileExists(kayıt) = False Then
alan1 = RightPadChar(" Kullanıcı Adı", " ", 40) & "/"
alan2 = RightPadChar("Tarih", " ", 30) & "/"
alan3 = RightPadChar("Saat", " ", 30) & "/"
alan4 = RightPadChar("Sayfa Hücre Adresi", " ", 30) & "/"
alan5 = RightPadChar("Eski Deger", " ", 30) & "/"
alan6 = RightPadChar("Yeni Deger", " ", 30) & "/"

yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6
Open kayıt For Append As #1
Print #1, yaz
Close #1
End If


alan1 = RightPadChar(Application.UserName & " Kullanıcı giris yapti", " ", 40) & "/"
alan2 = RightPadChar(Format(Now, "dd.mm.yyyy"), " ", 30) & "/"
alan3 = RightPadChar(Format(Now, "hh:nn:ss"), " ", 30) & "/"
alan4 = RightPadChar("", " ", 30) & "/"
alan5 = RightPadChar("", " ", 30) & "/"
alan6 = RightPadChar("", " ", 30) & "/"

yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6
Open kayıt For Append As #1
Print #1, yaz
Close #1

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

kayıt = ThisWorkbook.Path & "\kayit.txt"
alan1 = RightPadChar(Application.UserName & " Kullanicisi cikis yapti", " ", 40) & "/"
alan2 = RightPadChar(Format(Now, "dd.mm.yyyy"), " ", 30) & "/"
alan3 = RightPadChar(Format(Now, "hh:nn:ss"), " ", 30) & "/"
alan4 = RightPadChar("", " ", 30) & "/"
alan5 = RightPadChar("", " ", 30) & "/"
alan6 = RightPadChar("", " ", 30) & "/"

yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6
Open kayıt For Append As #1
Print #1, yaz
Close #1

ActiveWorkbook.Save
ThisWorkbook.Close savechanges:=False
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

kayıt = ThisWorkbook.Path & "\kayit.txt"

alan1 = RightPadChar(Application.UserName & " Kullanicisi kayıt yaptı", " ", 40) & "/"
alan2 = RightPadChar(Format(Now, "dd.mm.yyyy"), " ", 30) & "/"
alan3 = RightPadChar(Format(Now, "hh:nn:ss"), " ", 30) & "/"
alan4 = RightPadChar("", " ", 30) & "/"
alan5 = RightPadChar("", " ", 30) & "/"
alan6 = RightPadChar("", " ", 30) & "/"

yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6

Open kayıt For Append As #1
Print #1, yaz
Close #1

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Worksheets(ActiveSheet.Name).Cells(Rows.Count, 1).Value <> "." Then
Worksheets(ActiveSheet.Name).Cells(Rows.Count, 1) = "."
End If
If Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).Value <> "." Then
Worksheets(ActiveSheet.Name).Cells(1, Columns.Count) = "."
End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
sutun = Target.Column
satir = Target.Row

On Error Resume Next
If kontrol = False Then

alan1 = Application.UserName
alan2 = Format(Now, "dd.mm.yyyy")
alan3 = Format(Now, "hh:nn:ss")
alan4 = ActiveSheet.Name & "!" & Target.Address(1, 1)
alan5 = IIf(Eski_Değer = "", "Boş Hücre", Eski_Değer)
If Target = "" Then
alan6 = "Değer Silindi !"
ElseIf Target.HasFormula = True Then
alan6 = "'" & Target.Formula
Else
alan6 = Target
End If

alan1 = RightPadChar(alan1, " ", 40) & "/"
alan2 = RightPadChar(alan2, " ", 30) & "/"
alan3 = RightPadChar(alan3, " ", 30) & "/"
alan4 = RightPadChar(alan4, " ", 30) & "/"
alan5 = RightPadChar(alan5, " ", 30) & "/"
alan6 = RightPadChar(alan6, " ", 30) & "/"
yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6
kayıt = ThisWorkbook.Path & "\kayit.txt"

Open kayıt For Append As #1
Print #1, yaz
Close #1

End If

If Worksheets(ActiveSheet.Name).Cells(Rows.Count, 1).Value <> "." Then
'MsgBox Worksheets(ActiveSheet.Name).Cells(Rows.Count - 1, 1).Value
Worksheets(ActiveSheet.Name).Cells(Rows.Count, 1).Value = "."
Worksheets(ActiveSheet.Name).Cells(Rows.Count - 1, 1).Value = ""

alan1 = Application.UserName
alan2 = Format(Now, "dd.mm.yyyy")

alan3 = Format(Now, "hh:nn:ss")
alan4 = ActiveSheet.Name & "!" & Target.Address(1, 1)
alan5 = IIf(Eski_Değer = "", "", Eski_Değer)
alan6 = satir & " Satır silindi"

alan1 = RightPadChar(alan1, " ", 40) & "/"
alan2 = RightPadChar(alan2, " ", 30) & "/"
alan3 = RightPadChar(alan3, " ", 30) & "/"
alan4 = RightPadChar(alan4, " ", 30) & "/"
alan5 = RightPadChar(alan5, " ", 30) & "/"
alan6 = RightPadChar(alan6, " ", 30) & "/"
yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6
kayıt = ThisWorkbook.Path & "\kayit.txt"

Open kayıt For Append As #1
Print #1, yaz
Close #1

End If
If Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).Value <> "." Then
'MsgBox Worksheets(ActiveSheet.Name).Cells(1, Columns.Count - 1).Value
Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).Value = "."
Worksheets(ActiveSheet.Name).Cells(1, Columns.Count - 1).Value = ""

alan1 = Application.UserName
alan2 = Format(Now, "dd.mm.yyyy")
alan3 = Format(Now, "hh:nn:ss")
alan4 = ActiveSheet.Name & "!" & Target.Address(1, 1)
alan5 = IIf(Eski_Değer = "", "", Eski_Değer)
alan6 = sutun & " Sutun silindi"

alan1 = RightPadChar(alan1, " ", 40) & "/"
alan2 = RightPadChar(alan2, " ", 30) & "/"
alan3 = RightPadChar(alan3, " ", 30) & "/"
alan4 = RightPadChar(alan4, " ", 30) & "/"
alan5 = RightPadChar(alan5, " ", 30) & "/"
alan6 = RightPadChar(alan6, " ", 30) & "/"
yaz = alan1 & alan2 & alan3 & alan4 & alan5 & alan6
kayıt = ThisWorkbook.Path & "\kayit.txt"

Open kayıt For Append As #1
Print #1, yaz
Close #1

End If


kontrol = False

End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next

If Target.Count > 1 Then Exit Sub
If Target.HasFormula = True Then
Eski_Değer = "'" & Target.Formula
Else
Eski_Değer = Target
End If
kontrol = False
End Sub


Function RightPadChar(ByVal Astr As String, PadChar As String, stLen As Integer) As String
Dim AStrL As Integer
Astr = Trim(Astr)
AStrL = Len(Astr)
If AStrL < stLen Then
Astr = Astr + String(stLen - AStrL, PadChar)
Else
Astr = Mid$(Astr, 1, stLen)
End If
RightPadChar = Astr
End Function
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-03-2017, 08:35   #15
asas44
 
asas44 kullanıcısının avatarı
 
Giriş: 13/07/2013
Şehir: Fethiye
Mesaj: 66
Excel Vers. ve Dili:
2013 excel
Varsayılan

Halit bey elinize kolunuza sağlık.
asas44 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 03-03-2017, 06:38   #16
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,018
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Alıntı:
asas44 tarafından gönderildi Mesajı Görüntüle
Halit bey elinize kolunuza sağlık.
Teşekkürler iyi çalışmalar
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 03:24


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Hurda - Torna - Çorlu Web Tasarım - Tarot Falı - Fenerbahçe Haberleri - Trakya Haberleri - Investing - Hurda - Kobi Danışmanlık - Tekirdağ Samsung - Kozmetik Ürünler - Sağlıklı Makyaj Ürünleri - Yaşlanma Karşıtı Ürünler - Excel Eğitimi - Çorlu OSGB - Lingerie - Dyeing Machine - Çorlu Temizlik- Didim Çatı İnşaat- Çorlu Ambar- Hava Çekimi- Hazır Site- SEO- Çorlu Estetik
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden