İstediğim Sayfaları tek excel olarak Farklı Kaydetme (ÇÖZÜLDÜ)

[TanerSaydam]

Merhaba arkadaşlar,

Excel dosyamda ismi belirsiz sayfalar oluşturuyorum ve bunlardan istediklerimi tek bir excel olarak kaydetmek istiyorum.

Sayfaları tek tek kaydedebiliyorum ama benim istediğim seçtiklerimi tek bir excel olarak kaydetmek.

Şu anda kayıt için kullandıım kod bu.
For döngüsü ile c'nin ismini değiştirip, istediğim sayfaları ayrı ayrı kadediyorum.

Sheets(c).Copy
Sheets(c).SaveAs "C:\Users\Taner\Desktop\Denemeler\" & c & ".xlsx"
ActiveWorkbook.Close

 

[halit3]

Bu iş için en güzel userform kullnamak

Bir userform oluştur userformun üstüne
ListBox1
CommandButton1
CheckBox1

kod:

Private Sub CheckBox1_Click()
Dim i As Integer
For i = 1 To ListBox1.ListCount
ListBox1.Selected(i - 1) = CheckBox1.Value
Next
End Sub



Private Sub CommandButton1_Click()

Dim myArray() As Variant
Dim i As Integer

son = 0
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
son = 1
Exit For
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If

For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
ReDim Preserve myArray(n)
myArray(n) = i
n = n + 1
End If
Next

Sheets(myArray).Copy

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\deneme.xls"
ActiveWorkbook.Close SaveChanges:=False
MsgBox "Kayıt yapıldı", vbInformation


End Sub


Private Sub UserForm_Initialize()
ListBox1.ListStyle = 1
ListBox1.MultiSelect = 1

For i = 1 To ActiveWorkbook.Sheets.Count
ListBox1.AddItem Sheets(i).Name
Next i

End Sub

 

[halit3]

Bu kod daha iyi oldu

Private Sub CheckBox1_Click()
Dim i As Integer
For i = 1 To ListBox1.ListCount
ListBox1.Selected(i - 1) = CheckBox1.Value
Next
End Sub



Private Sub CommandButton1_Click()

Dim myArray() As Variant
Dim i As Integer


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

uzanti = "." & fL.GetExtensionName(ThisWorkbook.Name)

Klasor = ThisWorkbook.Path

son = 0
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
son = 1
Exit For
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If

For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
ReDim Preserve myArray(n)
myArray(n) = i
n = n + 1
End If
Next

Sheets(myArray).Copy

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

ActiveWorkbook.SaveAs Klasor & "\deneme" & sat & uzanti
ActiveWorkbook.Close SaveChanges:=False
MsgBox "Kayıt yapıldı", vbInformation


End Sub


Private Sub UserForm_Initialize()
ListBox1.ListStyle = 1
ListBox1.MultiSelect = 1

For i = 1 To ActiveWorkbook.Sheets.Count
ListBox1.AddItem Sheets(i).Name
Next i

End Sub

 

[TanerSaydam]

Deneyeceğim çok teşekkürler.

 

[TanerSaydam]

Halit bey kod mükemmel çalışıyor. Eğer aşağıdaki yazdığınız kodda ne işe yaradıklarını yazabilirseniz öğrenmem açısından daha kolay olur. Tekrardan teşekkürler.

Private Sub CommandButton1_Click()

Dim myArray() As Variant
Dim i As Integer


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

uzanti = "." & fL.GetExtensionName(ThisWorkbook.Name)

Klasor = ThisWorkbook.Path

son = 0
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
son = 1
Exit For
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If

For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
ReDim Preserve myArray(n)
myArray(n) = i
n = n + 1
End If
Next

Sheets(myArray).Copy

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

ActiveWorkbook.SaveAs Klasor & "\deneme" & sat & uzanti
ActiveWorkbook.Close SaveChanges:=False
MsgBox "Kayıt yapıldı", vbInformation


End Sub

 

[halit3]

Merhaba
bu iş buradaki kod da bitiyor.

Dim myArray() As Variant
Dim i As Integer


For i = 1 To ListBox1.ListCount
[COLOR="red"]'listeden seçim yapılıyorsa[/COLOR]
If ListBox1.Selected(i - 1) = True Then 
[COLOR="red"]'dizin adı[/COLOR]
ReDim Preserve myArray(n)
[COLOR="red"]'sayfa numaraları ile dizine alınıyor[/COLOR]
myArray(n) = i
n = n + 1
End If
Next

[COLOR="Red"]'dizine alınan bütün sayfaları seçiyor[/COLOR]
Sheets(myArray).Copy

ReDim Preserve (dinamik dizin)

 

[TanerSaydam]

Arşivimdeki yerini sayenizde alıyor Tekrar tekrar teşekkürler.