Selamlar üstadlar, aşağıdaki kodu arşivlemede kullanıyorum. Arşivleme yaptığım program masaüstünde iken bu kodlar sorunsuz çalışıyor ve istediğim klasöre arşivleme yapıyor. Arşivlemeyi google drive'a yapıyorum.
Ancak arşivle yaptığım programı google drive içindeki bir klasöre koyup arşivleme yapmaya çalışınca kod bazen arşivleme yapıyor, bazen hata veriyor, bazen kilitleniyor.
Nedenini anlayamadım.
Yardımcı olabilecek birisi var mıdır.
Dim syf As Worksheet
Set syf = Sheets("yetkili arsiv kullanicilar")
sifre = InputBox("Şifre Giriniz", "Şifre Giriş")
syf.Range("I2") = sifre
Dim path As String
Dim FileName As String
Dim sonsatir As Integer
Call yetkili_kullanici_arsiv1
On Error GoTo hata
yetkili_sifremi = WorksheetFunction.CountIf(syf.Range("e:e"), syf.Range("j2"))
yetkili_mi = WorksheetFunction.VLookup(syf.Range("j2"), syf.Range("c:d"), 2, 0)
tekrarli_sifremi = WorksheetFunction.CountIf(syf.Range("c:c"), syf.Range("j2"))
syf.Range("L2") = yetkili_mi
If tekrarli_sifremi > 1 Then
kullanici = InputBox("Kullanıcı adınızı giriniz.", "Şifreniz başka bir kullanıcı tarafından kullanılmaktadır.")
syf.Range("K2") = kullanici
kullanici_adi = WorksheetFunction.VLookup(syf.Range("N2"), syf.Range("A:G"), 7, 0)
If kullanici_adi = syf.Range("K2") Then
path = path = "G:\Ortak Drive'lar\01 Arşiv\c arşiv\onayli sayac\"
FileName = ActiveSheet.Range("A1")
ActiveSheet.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=path & FileName, FileFormat:=51
ActiveSheet.Shapes("CommandButton1").Delete
ActiveSheet.Shapes("CommandButton2").Delete
ActiveSheet.Shapes("CommandButton3").Delete
ActiveWorkbook.Close True
Sonsatır = Worksheets("yedek arsiv kayit").Range("a" & Rows.Count).End(xlUp).Row + 1
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 3).Value = Date
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 4).Value = Time
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 2).Value = syf.Range("J2")
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 1).Value = syf.Range("O2")
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 5).Value = ActiveSheet.Range("A1")
ActiveSheet.Range("c1:z5").Select
Selection.ClearContents
ActiveSheet.Range("A1").Select
MsgBox "Yedekleme İşleminiz Gerçekleştirilmiştir.", vbInformation
ElseIf kullanici_adi <> syf.Range("K2") Then
MsgBox ("Bu alana kayıt yapma yetkiniz bulunmamaktadır. Kullanıcı adınız yada şifreniz hatalıdır.")
Else
MsgBox ("Bu alana kayıt yapma yetkiniz bulunmamaktadır yada şifreniz hatalı olabilir.")
Exit Sub
End If
End If
hata:
Application.CutCopyMode = False
Err.Number = 0
If yetkili_sifremi = 1 And yetkili_mi = "yetkili" And tekrarli_sifremi = 1 Then
path = "G:\Ortak Drive'lar\01 Arşiv\c arşiv\onayli sayac\"
FileName = ActiveSheet.Range("A1")
ActiveSheet.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=path & FileName, FileFormat:=51
ActiveSheet.Shapes("CommandButton1").Delete
ActiveSheet.Shapes("CommandButton2").Delete
ActiveSheet.Shapes("CommandButton3").Delete
ActiveWorkbook.Close True
Sonsatır = Worksheets("yedek arsiv kayit").Range("a" & Rows.Count).End(xlUp).Row + 1
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 3).Value = Date
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 4).Value = Time
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 2).Value = syf.Range("J2")
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 1).Value = syf.Range("O2")
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 5).Value = ActiveSheet.Range("A1")
ActiveSheet.Range("c1:z5").Select
Selection.ClearContents
ActiveSheet.Range("A1").Select
MsgBox "Yedekleme İşleminiz Gerçekleştirilmiştir.", vbInformation
ElseIf tekrarli_sifremi > 1 Then
Exit Sub
Else
MsgBox ("Bu alana kayıt yapma yetkiniz bulunmamaktadır yada şifreniz hatalı olabilir.")
Exit Sub
End If
End Sub
Ancak arşivle yaptığım programı google drive içindeki bir klasöre koyup arşivleme yapmaya çalışınca kod bazen arşivleme yapıyor, bazen hata veriyor, bazen kilitleniyor.
Nedenini anlayamadım.
Yardımcı olabilecek birisi var mıdır.
Dim syf As Worksheet
Set syf = Sheets("yetkili arsiv kullanicilar")
sifre = InputBox("Şifre Giriniz", "Şifre Giriş")
syf.Range("I2") = sifre
Dim path As String
Dim FileName As String
Dim sonsatir As Integer
Call yetkili_kullanici_arsiv1
On Error GoTo hata
yetkili_sifremi = WorksheetFunction.CountIf(syf.Range("e:e"), syf.Range("j2"))
yetkili_mi = WorksheetFunction.VLookup(syf.Range("j2"), syf.Range("c:d"), 2, 0)
tekrarli_sifremi = WorksheetFunction.CountIf(syf.Range("c:c"), syf.Range("j2"))
syf.Range("L2") = yetkili_mi
If tekrarli_sifremi > 1 Then
kullanici = InputBox("Kullanıcı adınızı giriniz.", "Şifreniz başka bir kullanıcı tarafından kullanılmaktadır.")
syf.Range("K2") = kullanici
kullanici_adi = WorksheetFunction.VLookup(syf.Range("N2"), syf.Range("A:G"), 7, 0)
If kullanici_adi = syf.Range("K2") Then
path = path = "G:\Ortak Drive'lar\01 Arşiv\c arşiv\onayli sayac\"
FileName = ActiveSheet.Range("A1")
ActiveSheet.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=path & FileName, FileFormat:=51
ActiveSheet.Shapes("CommandButton1").Delete
ActiveSheet.Shapes("CommandButton2").Delete
ActiveSheet.Shapes("CommandButton3").Delete
ActiveWorkbook.Close True
Sonsatır = Worksheets("yedek arsiv kayit").Range("a" & Rows.Count).End(xlUp).Row + 1
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 3).Value = Date
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 4).Value = Time
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 2).Value = syf.Range("J2")
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 1).Value = syf.Range("O2")
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 5).Value = ActiveSheet.Range("A1")
ActiveSheet.Range("c1:z5").Select
Selection.ClearContents
ActiveSheet.Range("A1").Select
MsgBox "Yedekleme İşleminiz Gerçekleştirilmiştir.", vbInformation
ElseIf kullanici_adi <> syf.Range("K2") Then
MsgBox ("Bu alana kayıt yapma yetkiniz bulunmamaktadır. Kullanıcı adınız yada şifreniz hatalıdır.")
Else
MsgBox ("Bu alana kayıt yapma yetkiniz bulunmamaktadır yada şifreniz hatalı olabilir.")
Exit Sub
End If
End If
hata:
Application.CutCopyMode = False
Err.Number = 0
If yetkili_sifremi = 1 And yetkili_mi = "yetkili" And tekrarli_sifremi = 1 Then
path = "G:\Ortak Drive'lar\01 Arşiv\c arşiv\onayli sayac\"
FileName = ActiveSheet.Range("A1")
ActiveSheet.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=path & FileName, FileFormat:=51
ActiveSheet.Shapes("CommandButton1").Delete
ActiveSheet.Shapes("CommandButton2").Delete
ActiveSheet.Shapes("CommandButton3").Delete
ActiveWorkbook.Close True
Sonsatır = Worksheets("yedek arsiv kayit").Range("a" & Rows.Count).End(xlUp).Row + 1
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 3).Value = Date
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 4).Value = Time
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 2).Value = syf.Range("J2")
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 1).Value = syf.Range("O2")
Worksheets("yedek arsiv kayit").Cells(Sonsatır, 5).Value = ActiveSheet.Range("A1")
ActiveSheet.Range("c1:z5").Select
Selection.ClearContents
ActiveSheet.Range("A1").Select
MsgBox "Yedekleme İşleminiz Gerçekleştirilmiştir.", vbInformation
ElseIf tekrarli_sifremi > 1 Then
Exit Sub
Else
MsgBox ("Bu alana kayıt yapma yetkiniz bulunmamaktadır yada şifreniz hatalı olabilir.")
Exit Sub
End If
End Sub