Kapalı Çalışma Kitabının Sayfa Adını Değiştirme

B

BedriA

Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
Altın Üyelik Bitiş Tarihi
08/06/2018
Arkadaşlar,

Kapalı bir çalışma kitabındaki sayfanın adını "sayfa1" olarak değiştirmek istiyorum.

Kapalı çalışma kitabında sadece bir sayfanın ve bu sayfanın adının "Sayfa1" den farklı olduğu varsayılacaktır.

Veya;

Kapalı bir dosyadan veri aldığım aşağıdaki kodu sayfa adı ne olursa olsun, veri aktarma işlemini yapacak şekilde revize etmem gerekiyor.

Yardımcı olabilir misiniz?

Teşekkür ederim şimdiden.

Kod: 
Private Sub CommandButton8_Click()
Sheets("sorubank").Select
Dim conn As Object, rs As Object, sonsat As Long

On Error GoTo hata
ChDir ThisWorkbook.Path

dosya = Application.GetOpenFilename(FileFilter:="," & _
        "*.xls;*.xlsx;*.xlsm", _
        Title:="Lütfen dosya seçimi yapınız") ' uzantı eklemeleri yapabilirsiniz
    If dosya = False Then ' eğer vazgeçe basarsanız
        MsgBox "Dosya seçme işleminden vazgeçildi.", vbInformation, "         Bilgi"
        Exit Sub
    Else


Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("Adodb.recordset")

        
Application.ScreenUpdating = False
    conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & _
            dosya & ";extended properties=""excel 12.0;hdr=no""")
    rs.Open "select * from [[COLOR="Red"]Sayfa1[/COLOR]$A2:K65000];", conn, 1, 1
    If rs.RecordCount >= 0 Then
        sonsat = Cells(Rows.Count, "B").End(xlUp).Row
        Range("A" & sonsat + 1).CopyFromRecordset rs
        
    End If
    rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
Range("A1:K65000").HorizontalAlignment = xlCenter
Range("A1:K65000").VerticalAlignment = xlCenter

MsgBox "Dışarıan bankaya soru aktarıldı.", vbInformation, "         Bilgi"
End If
Exit Sub
 
hata:
    MsgBox "Klasör bulunamadı", vbCritical, "        UYARI"
End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,786
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kod:

Kod: 
Private Sub CommandButton8_Click()
Sheets("sorubank").Select
Dim conn As Object, rs As Object, sonsat As Long

On Error GoTo hata
ChDir ThisWorkbook.Path

dosya = Application.GetOpenFilename(FileFilter:="," & _
"*.xls;*.xlsx;*.xlsm", _
Title:="Lütfen dosya seçimi yapınız") ' uzantı eklemeleri yapabilirsiniz
If dosya = False Then ' eğer vazgeçe basarsanız
MsgBox "Dosya seçme işleminden vazgeçildi.", vbInformation, "         Bilgi"
Exit Sub
Else


[COLOR="red"]Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
'dosya_adı = dosya
'Data.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & dosya & ";"
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & dosya & ";"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then

sayfa_adi = Left$(son1, Len(son1) - 1)

Exit For
End If
End If
End If
End If
End If
Next

Set Data = Nothing
Set Katalog = Nothing[/COLOR]


Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("Adodb.recordset")

Application.ScreenUpdating = False
conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & _
dosya & ";extended properties=""excel 12.0;hdr=no""")
rs.Open "select * from [" [COLOR="Red"]& sayfa_adi &[/COLOR] "$A2:K65000];", conn, 1, 1
If rs.RecordCount >= 0 Then
sonsat = Cells(Rows.Count, "B").End(xlUp).Row
Range("A" & sonsat + 1).CopyFromRecordset rs

End If
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
Range("A1:K65000").HorizontalAlignment = xlCenter
Range("A1:K65000").VerticalAlignment = xlCenter

MsgBox "Dışarıan bankaya soru aktarıldı.", vbInformation, "         Bilgi"
End If
Exit Sub

hata:
MsgBox "Klasör bulunamadı", vbCritical, "        UYARI"
End Sub

veya aşağıdaki adresdeki dosyanın sayfasını bul

Kod: 
Private Sub CommandButton1_Click()

dosya = ThisWorkbook.Path & "\[COLOR="red"]sayfa.xls[/COLOR]"

Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
'dosya_adı = dosya
'Data.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & dosya & ";"
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & dosya & ";"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then

MsgBox Left$(son1, Len(son1) - 1)

Exit For
End If
End If
End If
End If
End If
Next

Set Data = Nothing
Set Katalog = Nothing

Set fL = Nothing

End Sub
 
B

BedriA

Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
Altın Üyelik Bitiş Tarihi
08/06/2018
halit3' Alıntı:
kod:

Kod: 
Private Sub CommandButton8_Click()
Sheets("sorubank").Select
Dim conn As Object, rs As Object, sonsat As Long

On Error GoTo hata
ChDir ThisWorkbook.Path

dosya = Application.GetOpenFilename(FileFilter:="," & _
"*.xls;*.xlsx;*.xlsm", _
Title:="Lütfen dosya seçimi yapınız") ' uzantı eklemeleri yapabilirsiniz
If dosya = False Then ' eğer vazgeçe basarsanız
MsgBox "Dosya seçme işleminden vazgeçildi.", vbInformation, "         Bilgi"
Exit Sub
Else


[COLOR="red"]Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
'dosya_adı = dosya
'Data.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & dosya & ";"
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & dosya & ";"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then

sayfa_adi = Left$(son1, Len(son1) - 1)

Exit For
End If
End If
End If
End If
End If
Next

Set Data = Nothing
Set Katalog = Nothing[/COLOR]


Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("Adodb.recordset")

Application.ScreenUpdating = False
conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & _
dosya & ";extended properties=""excel 12.0;hdr=no""")
rs.Open "select * from [" [COLOR="Red"]& sayfa_adi &[/COLOR] "$A2:K65000];", conn, 1, 1
If rs.RecordCount >= 0 Then
sonsat = Cells(Rows.Count, "B").End(xlUp).Row
Range("A" & sonsat + 1).CopyFromRecordset rs

End If
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
Range("A1:K65000").HorizontalAlignment = xlCenter
Range("A1:K65000").VerticalAlignment = xlCenter

MsgBox "Dışarıan bankaya soru aktarıldı.", vbInformation, "         Bilgi"
End If
Exit Sub

hata:
MsgBox "Klasör bulunamadı", vbCritical, "        UYARI"
End Sub

veya aşağıdaki adresdeki dosyanın sayfasını bul

Kod: 
Private Sub CommandButton1_Click()

dosya = ThisWorkbook.Path & "\[COLOR="red"]sayfa.xls[/COLOR]"

Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
'dosya_adı = dosya
'Data.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & dosya & ";"
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & dosya & ";"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then

MsgBox Left$(son1, Len(son1) - 1)

Exit For
End If
End If
End If
End If
End If
Next

Set Data = Nothing
Set Katalog = Nothing

Set fL = Nothing

End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim Halit Hocam.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst