VBA ile masa üstüne sayfa oluşturma

kalibre101 · 22 Mayıs 2022

merhabalar çalıştığım excel dosyamda sayfa indexsi 34 ve 51 arasında olanları masaüstüne yenibir excel dosyası oluşturup hepsini içine sayfa olarak kopyalamasını istiyorum kopyalarkende bazı sayfalarda nesneler var macro atadığım onlarıda silmesini istiyorum yardımcı olabilirseniz sevinirim.

kalibre101 · 22 Mayıs 2022

Kaydedilen dosyanın ismi mevcut ay& faaliyet raporu olabilirse memnun olurum mesela
Mayıs 2022 faaliyet raporu seklinde

AdemCan · 23 Mayıs 2022

Merhaba örnek kod.

Kod:

Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Dim dizi() As String, a As Byte, i As Byte, c As Object, ds As String, dn As String

ReDim dizi(17)
a = 0
For i = 1 To Sheets.Count
    If Sheets(i).Index >= 34 And Sheets(i).Index <= 51 Then
        dizi(a) = Sheets(i).Name
        a = a + 1
    End If
Next i

Sheets(dizi).Copy
ds = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & "\"
dn = Format(Date, "mmmm yyyy") & " Faaliyet Raporu.xlsx"
Application.ActiveWorkbook.SaveAs Filename:=ds & dn

For i = 1 To Sheets.Count
    For Each c In Sheets(i).Shapes
        c.Delete
    Next
Next i
Application.ActiveWorkbook.Close True

Erase dizi: a = 0: Set c = Nothing: i = 0: dn = "": ds = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

kalibre101 · 23 Mayıs 2022

AdemCan' Alıntı:

Merhaba örnek kod.

Kod:

Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Dim dizi() As String, a As Byte, i As Byte, c As Object, ds As String, dn As String

ReDim dizi(17)
a = 0
For i = 1 To Sheets.Count
    If Sheets(i).Index >= 34 And Sheets(i).Index <= 51 Then
        dizi(a) = Sheets(i).Name
        a = a + 1
    End If
Next i

Sheets(dizi).Copy
ds = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & "\"
dn = Format(Date, "mmmm yyyy") & " Faaliyet Raporu.xlsx"
Application.ActiveWorkbook.SaveAs Filename:=ds & dn

For i = 1 To Sheets.Count
    For Each c In Sheets(i).Shapes
        c.Delete
    Next
Next i
Application.ActiveWorkbook.Close True

Erase dizi: a = 0: Set c = Nothing: i = 0: dn = "": ds = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

c. delete kısmında hata verdi belirlenen değer aralık dışı dedi

AdemCan · 23 Mayıs 2022

Örnek dosyanızı paylaşır mısınız?

Kodu hazırlarken, Boş dosya üzerinde şekiller ekleyerek denedim ve hata vermeden işlem tamamlanıyor.

kalibre101 · 23 Mayıs 2022

AdemCan' Alıntı:
Örnek dosyanızı paylaşır mısınız?

Kodu hazırlarken, Boş dosya üzerinde şekiller ekleyerek denedim ve hata vermeden işlem tamamlanıyor.

dosyayı ekleyecegim yeri bulamadım yardımcı olursanız ekleyeyim

AdemCan · 23 Mayıs 2022

Altın Üye olmadığınız için siteye dosya ekleyemezsiniz ancak Google Drive, Microsoft OneDrive ya da diğer dosya paylaşım sitelerine yükleyip bağlantı adresi paylaşabilirsiniz.

Benim tercihim reklam vb. yönlendirmeler olmadığı için Google Drive ya da Microsoft OneDrive ile paylaşılması.

kalibre101 · 23 Mayıs 2022

,

AdemCan' Alıntı:
Altın Üye olmadığınız için siteye dosya ekleyemezsiniz ancak Google Drive, Microsoft OneDrive ya da diğer dosya paylaşım sitelerine yükleyip bağlantı adresi paylaşabilirsiniz.

Benim tercihim reklam vb. yönlendirmeler olmadığı için Google Drive ya da Microsoft OneDrive ile paylaşılması.

Günlük işletme ÇALIŞMA v125.xlsb

drive.google.com

dosyayı ekledim vba şifresi MERT2008

kalibre101 · 23 Mayıs 2022

kalibre101' Alıntı:
,

Günlük işletme ÇALIŞMA v125.xlsb

drive.google.com

dosyayı ekledim vba şifresi MERT2008

KAPAK-01 ile AKÜ48-15 arasındaki sayfalarını aktarmam gerekiyor
hatta masaüstü değilde C Sürücüsü işletme proğramı klasörünün içine atabilirseniz dahada iyi olur
klasör yoksa oluşturup içine atacak ay&faaliyet raporu şeklinde
çok teşekkürler

AdemCan · 23 Mayıs 2022

Dosyanızda VBA Penceresi için şifre bulunmaktadır, şifreyi paylaşır mısınız?

kalibre101 · 23 Mayıs 2022

AdemCan' Alıntı:
Dosyanızda VBA Penceresi için şifre bulunmaktadır, şifreyi paylaşır mısınız?
Ekli dosyayı görüntüle 236664

VBA = MERT2008
sayfa koruma= 2227
çalışma kitabı= 123

AdemCan · 23 Mayıs 2022

Kendi iş yerimizin işlerinden dolayı, dosyanızı bekletmem gerekiyor ancak paylaştığım kod Dosyanızda hata vermeden işlemleri tamamlıyor.
Klasör oluşturma isteğinize göre kodu güncelleyip yarın paylaşabilirim.

kalibre101 · 23 Mayıs 2022

AdemCan' Alıntı:
Kendi iş yerimizin işlerinden dolayı, dosyanızı bekletmem gerekiyor ancak paylaştığım kod Dosyanızda hata vermeden işlemleri tamamlıyor.
Klasör oluşturma isteğinize göre kodu güncelleyip yarın paylaşabilirim.

çok teşekkür ederim
acaba hata
ben windows 11 ve office 2021 kullanıyorum bununla alakalı olabilirmi
çünkü windows 11 de masaüstü yolu farklı oluyor
ondirive\desktop şeklinde

kalibre101 · 24 Mayıs 2022

şu şekilde kod denedim elimden geldiğince, çalışıyor ,eğer ekleme yapılcak veya düzeltilecek biyer varsa inceleyebilirsiniz

Sub DENEME()
Dim Yol As String, dizi(), a As Byte, h As Byte, t As Byte

Application.ScreenUpdating = False
Yol = "C:\İşletme Proğramı\"
If Dir(Yol, vbDirectory) = "" Then MkDir Yol
ThisWorkbook.Unprotect "123"
For h = 34 To 51
Sheets(h).Visible = True
Sheets(h).Unprotect "2227"
Next h
ReDim dizi(17)
a = 0
For i = 1 To Sheets.Count
If Sheets(i).Index >= 34 And Sheets(i).Index <= 51 Then
dizi(a) = Sheets(i).Name
a = a + 1
End If
Next i
Sheets(dizi).Copy _

ActiveWorkbook.SaveAs Yol & "Faaliyet Raporu.xlsx"
With ActiveWorkbook.Sheets("KAPAK-01")
.Shapes.Range(Array("Snip and Round Single Corner Rectangle 59")).Delete
End With
ActiveWorkbook.Save
ActiveWorkbook.Close 0
For t = 34 To 51
Sheets(t).Protect "2227"
ThisWorkbook.Sheets(t).Visible = False
Next t
ActiveWorkbook.Protect "123", Structure:=True, Windows:=False
MsgBox "İşleminiz tamamlanmıştır."
End Sub

kalibre101 · 24 Mayıs 2022

kalibre101' Alıntı:
şu şekilde kod denedim elimden geldiğince, çalışıyor ,eğer ekleme yapılcak veya düzeltilecek biyer varsa inceleyebilirsiniz

Sub DENEME()
Dim Yol As String, dizi(), a As Byte, h As Byte, t As Byte

Application.ScreenUpdating = False
Yol = "C:\İşletme Proğramı\"
If Dir(Yol, vbDirectory) = "" Then MkDir Yol
ThisWorkbook.Unprotect "123"
For h = 34 To 51
Sheets(h).Visible = True
Sheets(h).Unprotect "2227"
Next h
ReDim dizi(17)
a = 0
For i = 1 To Sheets.Count
If Sheets(i).Index >= 34 And Sheets(i).Index <= 51 Then
dizi(a) = Sheets(i).Name
a = a + 1
End If
Next i
Sheets(dizi).Copy _

ActiveWorkbook.SaveAs Yol & "Faaliyet Raporu.xlsx"
With ActiveWorkbook.Sheets("KAPAK-01")
.Shapes.Range(Array("Snip and Round Single Corner Rectangle 59")).Delete
End With
ActiveWorkbook.Save
ActiveWorkbook.Close 0
For t = 34 To 51
Sheets(t).Protect "2227"
ThisWorkbook.Sheets(t).Visible = False
Next t
ActiveWorkbook.Protect "123", Structure:=True, Windows:=False
MsgBox "İşleminiz tamamlanmıştır."
End Sub

,sizden ricam dosya ismini kayıt ettirirken sheets(1) range("f2") hücresinde girili olan tarihi ay yıl olarak alacak ve & faaliyet raporu olarak kaydedecek
şekilde düzenleyebilirmisiniz ayrıca eklemek veya düzeltmek istediğiniz biyer varsa memnun olurum teşekkür ederim.

AdemCan · 25 Mayıs 2022

Merhaba, klasör kontrolü ile işlem yapan kodlar, dosyanızda denedim ve hatasız işlem yapıyor.
KAPAK-01 ile AKÜ48-15 arasındaki sayfaları C sürücüsündeki İşletme Programı klasörünün içerisine kayıt eder.

Kod:

Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Dim dizi() As String, a As Byte, i As Byte, c As Object, ds As String, dn As String
Dim fso As Object, kontrol As Boolean

Set fso = CreateObject("Scripting.FileSystemObject")

ds = "C:\İşletme Programı\"
kontrol = fso.FolderExists(ds)

If kontrol = False Then
    fso.CreateFolder "C:\İşletme Programı"
End If

dn = Format(Sheets("ANASAYFA").Range("F2").Text, "mmmm yyyy") & " Faaliyet Raporu.xlsx"

ReDim dizi(15)
a = 0
For i = 34 To 49
        dizi(a) = Sheets(i).Name
        a = a + 1
Next i

Sheets(dizi).Copy
Application.ActiveWorkbook.SaveAs Filename:=ds & dn

For i = 1 To Sheets.Count
    For Each c In Sheets(i).Shapes
        c.Delete
    Next
    Sheets(i).Cells.Copy
    Sheets(i).Cells.PasteSpecial Paste:=xlPasteValues
Next i
Application.ActiveWorkbook.Close True

Erase dizi: a = 0: Set c = Nothing: i = 0: dn = "": ds = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

kalibre101 · 25 Mayıs 2022

AdemCan' Alıntı:

Merhaba, klasör kontrolü ile işlem yapan kodlar, dosyanızda denedim ve hatasız işlem yapıyor.
KAPAK-01 ile AKÜ48-15 arasındaki sayfaları C sürücüsündeki İşletme Programı klasörünün içerisine kayıt eder.

Kod:

Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Dim dizi() As String, a As Byte, i As Byte, c As Object, ds As String, dn As String
Dim fso As Object, kontrol As Boolean

Set fso = CreateObject("Scripting.FileSystemObject")

ds = "C:\İşletme Programı\"
kontrol = fso.FolderExists(ds)

If kontrol = False Then
    fso.CreateFolder "C:\İşletme Programı"
End If

dn = Format(Sheets("ANASAYFA").Range("F2").Text, "mmmm yyyy") & " Faaliyet Raporu.xlsx"

ReDim dizi(15)
a = 0
For i = 34 To 49
        dizi(a) = Sheets(i).Name
        a = a + 1
Next i

Sheets(dizi).Copy
Application.ActiveWorkbook.SaveAs Filename:=ds & dn

For i = 1 To Sheets.Count
    For Each c In Sheets(i).Shapes
        c.Delete
    Next
    Sheets(i).Cells.Copy
    Sheets(i).Cells.PasteSpecial Paste:=xlPasteValues
Next i
Application.ActiveWorkbook.Close True

Erase dizi: a = 0: Set c = Nothing: i = 0: dn = "": ds = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

Çok teşekkür ederim