Makroda Düzenleme

[ormann]

Merhabalar ;
Ekli dosyada dikili girişi sayfasında aktar butonuna bastığımda veriler masaüstünde DAMGALARIM klasörü içerisine dikili girişi sayfasındaki T3 hücresindeki isimle kayıt yapılıyor.Fakat veriler Dikili sayfasındaki D17:L65000 hücre aralığında kopyalanması gerekirken Dikili girişi sayfasındaki L sütün daki veriler kopyalana DikiliDamga sayfasında da L sütununa gelmesi gerekirken I sütununa geliyor. Yardımcı olursanız sevinirim.

İndir VERİ

Dosyayı indir VERİ

dosya.co

Sub damgalarım()
yol = masaustubul()

Application.DisplayAlerts = False
    Sayfa1.Range("D17:L65000").Copy
    Workbooks.Add
    Sheets("Sayfa1").Select
    Sheets("Sayfa1").Name = "DikiliDamga"
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A1:A5000").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.NumberFormat = "m/d/yyyy"
        If Dir(yol & "\DAMGALARIM", vbDirectory) = "" Then
            MkDir (yol & "\DAMGALARIM")
        End If
          ActiveWorkbook.SaveAs Filename:=yol & "\DAMGALARIM\" & Sayfa1.Range("T3") & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
Application.DisplayAlerts = True


End Sub
Function masaustubul() As String
     Set kod = CreateObject("WScript.Shell")
     masaustubul = kod.SpecialFolders("Desktop")
        Set kod = Nothing
    Exit Function

End Function

 

[muratboz06]

Mevcut dosyada veriniz D sütununda başlıyor, kayıt yaptığınız sayfada ise A1 e kopyala demişsiniz.
Range("A1").Select ifadesini
Range("D1").Select olarak değiştirirseniz olacaktır.

Range("A1:A5000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "m/d/yyyy"
yazan satırları silerek
Columns(4).NumberFormat = "m/d/yyyy" ile değiştiriniz.

 

[ormann]

Murat bey bu seferde veriler D sununa aktarılıyor. Veriler Dikili Girişi sayfasında ki hücrelerin aynısı aynı yerlere kopyalanması gerekiyor.

 

[muratboz06]

Veriler her zaman D17 de başlıyor ise;
Range("D1").Select yazan yeri Range("D17").Select yapınız. (ilk yazdığınız mesajdan sorunuz tam anlaşılmıyor, veya ben anlamadım.)

 

[ormann]

Murat bey yeni dosyada veriler D1 hücesine yapıştırılacak.

 

[ormann]

Dikili girişindeki D17:I5000 hücresindeki veriler yeni oluşan dosyada A1:F5000 hücresine
Dikili girişindeki L17:L5000 hücresindeki veriler yeni oluşan dosyada L1:L5000 hücresine kopyalanacak

 

[muratboz06]

Kendi kodunuzu aşağıdaki kod ile değiştiriniz.

Sub damgalarım()
yol = masaustubul()

Application.DisplayAlerts = False
    Sayfa1.Range("D17:L65000").Copy
    Workbooks.Add
    Sheets("Sayfa1").Select
    Sheets("Sayfa1").Name = "DikiliDamga"
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A1:A5000").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.NumberFormat = "m/d/yyyy"
    Columns("G:I").EntireColumn.Insert
    Columns("A:L").EntireColumn.AutoFit
           If Dir(yol & "\DAMGALARIM", vbDirectory) = "" Then
            MkDir (yol & "\DAMGALARIM")
        End If
          ActiveWorkbook.SaveAs Filename:=yol & "\DAMGALARIM\" & Sayfa1.Range("T3") & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
Application.DisplayAlerts = True


End Sub
Function masaustubul() As String
     Set kod = CreateObject("WScript.Shell")
     masaustubul = kod.SpecialFolders("Desktop")
        Set kod = Nothing
    Exit Function

End Function

End Sub

 

[ormann]

Murat bey çok teşekkür ederim.