• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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
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
 
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
 
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.
Geri
Üst