Makro Kod Listesi
Excel de kullanılan Makro Kodlarının Listesi


dosya sayısı

ID : 721
ISLEM : dosya sayısı
MAKRO KODU : Sub Dosya_Sayısı() Dim ds, dc, f, s Set ds = CreateObject("Scripting.FileSystemObject") Set f = ds.GetFolder("C:\SXS") Set dc = f.Files s = dc.Count MsgBox s End Sub

dosya silmek

ID : 722
ISLEM : dosya silmek
MAKRO KODU : Sub sil() Kill "C:\Documents And Settings\pir\Belgelerim\pir.xls" End Sub

dosya sistemini gösterme

ID : 723
ISLEM : dosya sistemini gösterme
MAKRO KODU : Sub Dosya_Sistemi_Göster() Dim ds, d, s Set ds = CreateObject("Scripting.FileSystemObject") Set d = ds.GetDrive("C:\") s = d.FileSystem MsgBox s End Sub

dosya sistemini öğrenme

ID : 724
ISLEM : dosya sistemini öğrenme
MAKRO KODU : Private Declare Function GetVolumeInformation Lib "Kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long Sub Dosya_Sistemi() Dim DosyaSistemi As String DosyaSistemi = String$(255, Chr$(0)) GetVolumeInformation "C:\", 0, 255, 0, 0, 0, DosyaSistemi, 255 DosyaSistemi = Left$(DosyaSistemi, InStr(1, DosyaSistemi, Chr$(0)) - 1) MsgBox DosyaSistemi End Sub

dosya taşıma

ID : 725
ISLEM : dosya taşıma
MAKRO KODU : Sub Dosya_Taşı() Dim ds, f Set ds = CreateObject("Scripting.FileSystemObject") f = ds.MoveFile("D:\ExcelÖrnekleri\Move.xls", "C:\") End Sub

dosya uzantısını verir

ID : 726
ISLEM : dosya uzantısını verir
MAKRO KODU : Sub Uzantı_İsmi() Dim ds, f Set ds = CreateObject("Scripting.FileSystemObject") f = ds.GetExtensionName("D:\ExcelÖrnekleri\Soru.xls") MsgBox f End Sub

dosya yedekleme

ID : 727
ISLEM : dosya yedekleme
MAKRO KODU : Sub Yedek() '/_ Dismi= ActiveWorkbook.Name ActiveWorkbook.SaveCopyAs "D:\Alihan_Bordro\ " & Dismi ActiveWorkbook.Save End Sub

dosya yedekleme mesaj kutusu ile ismini yaz

ID : 728
ISLEM : dosya yedekleme mesaj kutusu ile ismini yaz
MAKRO KODU : Sub Enregistre_Sous() Réponse = MsgBox("Voulez-vous enregistrer ce classeur ?", vbYesNo) If Réponse = vbYes Then Nom = InputBox("Donnez un nom de fichier !" & Chr(13) & "Exemple: Rapport") If Nom = "" Then Exit Sub Else GoTo continu End If continu: ChDrive "c" ChDir "c:\" 'Indiquez le répertoire ActiveWorkbook.SaveAs Filename:=(Nom) End If End Sub

dosya yolu ve uzantısını belirle ayrıntılı listelesin

ID : 729
ISLEM : dosya yolu ve uzantısını belirle ayrıntılı listelesin
MAKRO KODU : Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" _ (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Private z! Function GetDirectory(Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer With bInfo .pidlRoot = 0& .lpszTitle = Msg .ulFlags = &H1 End With x = SHBrowseForFolder(bInfo) path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Else GetDirectory = "" End If End Function Sub Dateisuche(Laufwerk, Dateien) Dim tmp, Wdhlg, Dateiname As String On Error Resume Next If Right(Laufwerk, 1) "\" Then Laufwerk = Laufwerk + "\" tmp = Dir(Laufwerk & Dateien) Do While Len(tmp) Dateiname = Laufwerk & tmp Application.StatusBar = Dateiname Cells(z, 1).Select Cells(z, 1) = Laufwerk & tmp 'Pfad Cells(z, 2) = FileLen(Laufwerk & tmp) 'Größe Cells(z, 3) = FileDateTime(Laufwerk & tmp) 'Datum/Zeit Cells(z, 4) = tmp 'nur Dateiname z = z + 1 tmp = Dir() Loop tmp = Dir(Laufwerk, vbDirectory) Do While Len(tmp) If (tmp ".") And (tmp "..") Then If (GetAttr(Laufwerk & tmp) And vbDirectory) = vbDirectory Then Dateisuche Laufwerk & tmp, Dateien z = z - 1 Wdhlg = Dir(Laufwerk, vbDirectory) z = z + 1 Do While Wdhlg tmp Wdhlg = Dir() Loop End If End If tmp = Dir() Loop On Error GoTo 0 Application.StatusBar = False End Sub Sub Suchen() Dim Laufwerk$, Dateien$ 'Ersze Zeile, in der eine Eintragung erfolgt z = 2 'Alte Eintragungen löschen [a1:e5000] = "" 'Ersatz: ... = "C:\Eigene Dateien" Laufwerk = GetDirectory("Bitte einen Ordner wählen") If Laufwerk = "" Then Exit Sub 'Ersatz: Dateien = "*.*" Dateien = InputBox("Nach welchen Dateien soll in" & _ Chr(10) & " " & Laufwerk & Chr(10) & _ "gesucht werden (z. B. *.xls)?", _ "Dateityp", "*.*") If Dateien = "" Then Exit Sub Dateisuche Laufwerk, Dateien End Sub -

dosya yoluna göre excelden excele yükleme

ID : 730
ISLEM : dosya yoluna göre excelden excele yükleme
MAKRO KODU : Sub a() Set xl = CreateObject("Excel.Sheet") xl.Application.Workbooks.Open Range("K1") End Sub

dosya yolunda excel dosyalarını bulur ve açar

ID : 731
ISLEM : dosya yolunda excel dosyalarını bulur ve açar
MAKRO KODU : Sub ExcelDateienÖffnen() With Application.FileSearch .NewSearch .LookIn = "C:\" ‘\Belgelerim şeklinde de olabilir. .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks .Execute For i = 1 To .FoundFiles.Count Workbooks.Open .FoundFiles(i) Next i End With End Sub

dosya yolunu göster ayrıntılı olarak listelesin dosyaların kapladıkları alanları, dosya yolunu vs…

ID : 732
ISLEM : dosya yolunu göster ayrıntılı olarak listelesin dosyaların kapladıkları alanları, dosya yolunu vs…
MAKRO KODU : Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Sub Verzeichnisse_auflisten() Dim Pfad1, Name1, Anzahl, X, X0, X1, X2, Verz, Anzverz, Größe Dim TB1, TB2 As Worksheet Dim msg As String Set TB1 = ThisWorkbook.Worksheets(1) Set TB2 = ThisWorkbook.Worksheets(2) start = Now TB1.[a:D] = "" TB2.[a:D] = "" If ThisWorkbook.Worksheets.Count > 2 Then Application.DisplayAlerts = False For X = 3 To ThisWorkbook.Worksheets.Count ThisWorkbook.Worksheets(3).Delete Next X Application.DisplayAlerts = True End If msg = "Wählen Sie bitte einen Ordner aus:" Pfad1 = getdirectory(msg) If Pfad1 = "" Then Exit Sub Name1 = Dir(Pfad1, vbDirectory) TB1.[a2] = Pfad1 Anzahl = 2 TB1.[a1] = "Pfad" TB1.[b1] = "UnterVerz." TB1.[c1] = "Anz. Dateien" TB1.[d1] = "Datgröße in Verz." X0 = 2 X1 = 2 Do While TB1.Cells(Rows.Count, 1).End(xlUp).Row TB1.Cells(Rows.Count, 2).End(xlUp).Row For X2 = X0 To X1 Pfad1 = TB1.Cells(X2, 1) If Right(Pfad1, 1) "\" Then Pfad1 = Pfad1 & "\" Name1 = Dir(Pfad1, vbDirectory) Verz = 0 Do While Name1 "" If Name1 "." And Name1 ".." Then If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then Anzahl = Anzahl + 1 TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & "\" Verz = Verz + 1 End If End If Name1 = Dir Loop TB1.Cells(X2, 2) = Verz Next X2 X0 = X1 + 1 X1 = X2 Loop Anzverz = TB1.Cells(Rows.Count, 1).End(xlUp).Row i = 1 ii = 0 For Verz = 2 To Anzverz Anzahl = 0 Größe = 0 Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(TB1.Cells(Verz, 1)) Set fc = f.Files For Each f1 In fc If i = 65536 Then ii = ii + 1 ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) ThisWorkbook.Worksheets(ii + 2).Name = "Dateien " & ii + 1 Set TB2 = ThisWorkbook.Worksheets(ii + 2) i = 1 End If i = i + 1 Anzahl = Anzahl + 1 TB2.Cells(i, 1) = f1.Name TB2.Cells(i, 2) = f & "\" & f1.Name 'Hyperlink auf die Datei einfügen TB2.Hyperlinks.Add Anchor:=TB2.Cells(i, 2), Address:= _ f & "\" & f1.Name TB2.Cells(i, 3) = FileLen(f1) TB2.Cells(i, 4) = FileDateTime(f1) Größe = Größe + FileLen(f1) Next TB1.Cells(Verz, 3) = Anzahl TB1.Cells(Verz, 4) = Größe / 1024 / 1024 Next Verz 'MsgBox (ii * 65536) + i ende = Now MsgBox "Anzahl der Verzeichnisse: " & Verz & Chr(13) & _ "Anzahl der Dateien: " & (ii * 65536) + i & Chr(13) & _ Chr(13) & "Dauer: " & Format(ende - start, "nn:ss") End Sub Function getdirectory(Optional msg) As String Dim bInfo As BROWSEINFO Dim Path As String Dim r As Long, X As Long, pos As Integer ' Ausgangsordner = Desktop bInfo.pidlRoot = 0& If IsMissing(msg) Then bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus." Else bInfo.lpszTitle = msg End If bInfo.ulFlags = &H1 X = SHBrowseForFolder(bInfo) Path = Space$(512) r = SHGetPathFromIDList(ByVal X, ByVal Path) If r Then pos = InStr(Path, Chr$(0)) getdirectory = Left(Path, pos - 1) Else getdirectory = "" End If End Function -

dosya, düzen menüsüne menü ekleme

ID : 733
ISLEM : dosya, düzen menüsüne menü ekleme
MAKRO KODU : Private Sub Workbook_Open() Dim cmb As CommandBar Dim cmbp As CommandBarPopup Set cmb = Application.CommandBars. _ Add(Name:="MeineLeiste", _ Position:=msoBarTop, _ Temporary:=True) Set cmbp = cmb.Controls.Add(Type:=msoControlPopup) cmb.Visible = True cmbp.Caption = "Mein Submenü" With cmbp.Controls.Add(Type:=msoControlButton, _ Temporary:=True) .Caption = "Meine 1. Prozedur" .BeginGroup = True .FaceId = 59 .OnAction = "MeineProzedur1" End With With cmbp.Controls.Add(Type:=msoControlButton, _ Temporary:=True) .Caption = "Meine 2. Prozedur" .FaceId = 49 .OnAction = "MeineProzedur2" End With Set cmb = Nothing Set cmbp = Nothing End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim cmb As CommandBar Set cmb = Application.CommandBars("MeineLeiste") cmb.Delete Set cmb = Nothing End Sub Sub MeineProzedur1() MsgBox Application.UserName End Sub Sub MeineProzedur2() MsgBox Now() End Sub

dosya, görünüm, düzen menüsünü gizle göster

ID : 734
ISLEM : dosya, görünüm, düzen menüsünü gizle göster
MAKRO KODU : Sub MenueleisteAusblenden() Application.CommandBars("Worksheet Menu Bar").Enabled = False End Sub Sub MenueleisteAusblenden() Application.CommandBars("Worksheet Menu Bar").Enabled = True End Sub

dosya, menü çubuğunu gizle

ID : 735
ISLEM : dosya, menü çubuğunu gizle
MAKRO KODU : Application.CommandBars.ActiveMenuBar.Enabled = False

dosyada kişi resmi olmadiğinda formdaki image'nin boş olmasi

ID : 736
ISLEM : dosyada kişi resmi olmadiğinda formdaki image'nin boş olmasi
MAKRO KODU : On Error GoTo hata If foto False Then Image1.Picture = LoadPicture("E:\Office\WINDOWS\Resim\" & foto & ".bmp") 'BU SATIRIN ÇALIŞMASI İÇİN "C" BÖLÜMÜNE "Resim" adında bir klasör açıp içine resimleri kişilerin kendi isimleriyle kaydedin. Image1.PictureSizeMode = fmPictureSizeModeStretch End If End If Next bak Exit Sub hata: Image1.Picture =loadpicture("") -

dosyamızı silme

ID : 737
ISLEM : dosyamızı silme
MAKRO KODU : Sub dosyasil() On Error Resume Next RmDir "C:\pir\xp\beyza" End Sub

dosyanın açık olup olmadığına bakar açık değilse açar

ID : 738
ISLEM : dosyanın açık olup olmadığına bakar açık değilse açar
MAKRO KODU : Function WorkbookOpen(WorkBookName As String) As Boolean WorkbookOpen = False On Error GoTo WorkBookNotOpen If Len(Application.Workbooks(WorkBookName).Name) > 0 Then WorkbookOpen = True Exit Function End If WorkBookNotOpen: End Function Sub AA() If Not WorkbookOpen("C.xls") Then Workbooks.Open "C.xls" End If End Sub

dosyanın açılma tarih ve saatini txt'ye işler (alt alta)

ID : 739
ISLEM : dosyanın açılma tarih ve saatini txt'ye işler (alt alta)
MAKRO KODU : Private Sub Workbook_Open() Open ThisWorkbook.Path & "\pirr.log" For Append As #1 Print #1, Application.UserName, Now Close #1 End Sub

dosyanın tarihini yazın kaç gün geçtiğin hesaplasın

ID : 740
ISLEM : dosyanın tarihini yazın kaç gün geçtiğin hesaplasın
MAKRO KODU : Sub Auto_Open() Dim exdate As Date exdate = "11/30/2004" If Date > exdate Then MsgBox ("You have reached end of your trail period") ActiveWorkbook.Close End If MsgBox ("You have " & exdate - Date & "Days left") End Sub

dosyanın yolunu ve ismini hücreye yazdırır

ID : 741
ISLEM : dosyanın yolunu ve ismini hücreye yazdırır
MAKRO KODU : Function CreateFileList(FileFilter As String, _ IncludeSubFolder As Boolean) As Variant Dim FileList() As String, FileCount As Long CreateFileList = "" Erase FileList If FileFilter = "" Then FileFilter = "*.*" ' all files With Application.FileSearch .NewSearch .LookIn = CurDir .Filename = FileFilter .SearchSubFolders = IncludeSubFolder .FileType = msoFileTypeAllFiles If .Execute(SortBy:=msoSortByFileName, _ SortOrder:=msoSortOrderAscending) = 0 Then Exit Function ReDim FileList(.FoundFiles.Count) For FileCount = 1 To .FoundFiles.Count FileList(FileCount) = .FoundFiles(FileCount) Next FileCount .FileType = msoFileTypeExcelWorkbooks ' reset filetypes End With CreateFileList = FileList Erase FileList End Function Sub TestCreateFileList() Dim FileNamesList As Variant, i As Integer 'ChDir "C:\My Documents" FileNamesList = CreateFileList("*.*", False) Range("A:A").ClearContents For i = 1 To UBound(FileNamesList) Cells(i + 1, 1).Formula = FileNamesList(i) Next i End Sub

dosyanızı istediğiniz klasöre yedekleyin

ID : 742
ISLEM : dosyanızı istediğiniz klasöre yedekleyin
MAKRO KODU : Sub Yedek() '/_ Dismi= ActiveWorkbook.Name ActiveWorkbook.SaveCopyAs "D:\Alihan_Bordro\ " & Dismi ActiveWorkbook.Save End Sub

dosyanin bayt cinsinden büyüklüğü nedir?

ID : 743
ISLEM : dosyanin bayt cinsinden büyüklüğü nedir?
MAKRO KODU : A ya dosya ismini Bye Bayt cinsini Cye de tarihini yazar Kod: Sub Dateiname_Hyperlink() Dim StDateiname As String Dim Dateiform As String Dim InI As Long, TotFiles As Long Dim Suchpfad As String Dim OldStatus As Variant Suchpfad = InputBox("Yolunu değiştirebilirsiniz", "Adres yolu", Application.DefaultFilePath) If Suchpfad = "" Then Exit Sub Dateiform = InputBox("Dosya uzantısını siz değiştiriniz", "Uzantı", "*.xls") If Dateiform = "" Then Exit Sub Application.ScreenUpdating = True OldStatus = Application.StatusBar Sheets.Add After:=Worksheets(Worksheets.Count) With Application.FileSearch .LookIn = Suchpfad .SearchSubFolders = True .Filename = Dateiform If .Execute() > 0 Then TotFiles = .FoundFiles.Count Application.StatusBar = "Total " & TotFiles & " gefunden" For InI = 1 To .FoundFiles.Count Application.StatusBar = "Datei: " & InI & " von " & TotFiles StDateiname = Mid(.FoundFiles(InI), InStrRev(.FoundFiles(InI), "\") + 1) ActiveSheet.Hyperlinks.Add Anchor:=Cells(InI, 1), _ Address:=.FoundFiles(InI), TextToDisplay:=StDateiname Cells(InI, 2) = FileLen(.FoundFiles(InI)) Cells(InI, 3) = FileDateTime(.FoundFiles(InI)) Next InI End If End With Application.StatusBar = OldStatus Application.ScreenUpdating = True End Sub

dosyayı farklı şekillerde kaydetme

ID : 744
ISLEM : dosyayı farklı şekillerde kaydetme
MAKRO KODU : Sub auto_close() sor = MsgBox("Güle güle " & Format(Now, "dd.mmmm.yy hh:mm") & Chr(10) & Chr(10) & "dosyanın kaydedilmesini istiyormusunuz?", 4, "") If sor = vbYes Then ActiveWorkbook.Save ActiveWorkbook.Close Else Application.DisplayAlerts = False ActiveWorkbook.Close End If End Sub

dosyayı kapama

ID : 745
ISLEM : dosyayı kapama
MAKRO KODU : Sub kapa() MsgBox "Bu programı pir düzenlemiştir.", , "KAPATILIYOR" ActiveWorkbook.Close True End Sub

dosyayı kim açtı

ID : 746
ISLEM : dosyayı kim açtı
MAKRO KODU : ThisWorkBook yazılacak. 'Ayrıca C:\acılısarsiv.txt olarak ayrıca txt dosyası oluşturuyor.. Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String LastOpen = GetSetting("xxrt", "Dosya", "Opened", "") [a1] = "En son açılış tarihi: " & LastOpen [a2] = "Dosyayı en son açan kullanıcı: " & Application.UserName LastOpen = Date & " " & Time SaveSetting "xxrt", "Dosya", "Opened", LastOpen Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim i As Integer Open "C:\acılısarsiv.txt" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text Print #1, veri1; " "; veri2; Next i Close #1 'C Klasöründe txt hazırladı 'enson açan kişinin yazılı bulunduğuSayfa1 a1 ve a2 deki verileri siler.. 'eğer Sayfa1'de silmesini istemezseniz aşağıdakileri silin. Sheets("Sayfa1").Select Range("A1:A2").Select Selection.ClearContents Range("A1").Select End Sub 'Mesaj olarakta [a1] = "En son açılış tarihi: " & LastOpen [a2] = "Dosyayı en son açan kullanıcı: " & Application.UserName 'Kodlarının altına bunları yazın. MsgBox "En son açılış tarihi: " & LastOpen MsgBox "Dosyayı en son açan kullanıcı: " & Application.UserName

dosyayı kim ne zaman hangi tarihte açtı txt

ID : 747
ISLEM : dosyayı kim ne zaman hangi tarihte açtı txt
MAKRO KODU : ThisWorkbook'a Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String LastOpen = GetSetting("xxrt", "Dosya", "Opened", "") [a1] = "En son açılış tarihi: " & LastOpen [a2] = "Dosyayı en son açan kullanıcı: " & Application.UserName MsgBox "En son açılış tarihi: " & LastOpen MsgBox "Dosyayı en son açan kullanıcı: " & Application.UserName LastOpen = Date & " " & Time SaveSetting "xxrt", "Dosya", "Opened", LastOpen Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim i As Integer Open "C:\acılısarsiv.txt" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text Print #1, veri1; " "; veri2; Next i Close #1 'C Klasöründe txt hazırladı 'enson açan kişinin yazılı bulunduğuSayfa1 a1 ve a2 deki verileri siler.. 'eğer Sayfa1'de silmesini istemezseniz aşağıdakileri silin. Sheets("Sayfa1").Select Range("A1:A2").Select Selection.ClearContents Range("A1").Select End Sub

dosyayı sizden başkası kaydetmesin

ID : 748
ISLEM : dosyayı sizden başkası kaydetmesin
MAKRO KODU : Private Sub Workbook_BeforeSave _ (ByVal SaveAsUI As Boolean, Cancel As Boolean) sifre = InputBox("İşçi Maaş İcmali olduğundan Kayıt için Şifre Girmelisiniz.", _ "Yetkili Kişi", "Kaydetmek İçin Şifre girin") If sifre = "123456" Then'Örnek Şifre olarak 123456 MsgBox "Kayıt işlemi tamamlandı", vbInformation, _ "KAYIT BAŞARILI" Else MsgBox "Yanlış şifre girdiniz." & Chr(13) & _ "Dosya kaydedilemedi", vbCritical, "HATALI ŞİFRE" Cancel = True End If End Sub

dosyayı tarihli olarak kayıt etme

ID : 749
ISLEM : dosyayı tarihli olarak kayıt etme
MAKRO KODU : Option Explicit Sub DateAsFilename() Dim sFileName As String sFileName = Format(Now, "dd.mm.yyyy") + ".xls" ' tarih formatını değiştirebilirsiniz (ddmmyy) gibi ActiveWorkbook.SaveAs sFileName End Sub

dosyayi kim açti

ID : 750
ISLEM : dosyayi kim açti
MAKRO KODU : Sanırım Dosyanız Çok gizli olsa gerek..Dosyanızda silinme riskini düşünerek bu kodlara ihtiyaç duyduğunuzu umarım.Yoksa Bilgilerinizi makrolarınızı sizde paylaşmak istersiniz..Neyse aşağıdaki kod tam çözüm olmamakla birlikte bu kodlar ThisWorkBook yazılacak. .Ayrıca C:\acılısarsiv.txt olarak ayrıca txt dosyası oluşturuyor.. Kod: Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String LastOpen = GetSetting("xxrt", "Dosya", "Opened", "") [a1] = "En son açılış tarihi: " & LastOpen [a2] = "Dosyayı en son açan kullanıcı: " & Application.UserName LastOpen = Date & " " & Time SaveSetting "xxrt", "Dosya", "Opened", LastOpen Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim i As Integer Open "C:\acılısarsiv.txt" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text Print #1, veri1; " "; veri2; Next i Close #1 'C Klasöründe txt hazırladı 'enson açan kişinin yazılı bulunduğuSayfa1 a1 ve a2 deki verileri siler.. 'eğer Sayfa1'de silmesini istemezseniz aşağıdakileri silin. Sheets("Sayfa1").Select Range("A1:A2").Select Selection.ClearContents Range("A1").Select End Sub Mesaj olarakta Kod: [a1] = "En son açılış tarihi: " & LastOpen [a2] = "Dosyayı en son açan kullanıcı: " & Application.UserName Kodlarının altına bunları yazın.Kod: MsgBox "En son açılış tarihi: " & LastOpen MsgBox "Dosyayı en son açan kullanıcı: " & Application.UserName

* Görseller ve İçerik tekif hakkına sahip olabilir