Soru Bir klasörde eklenecek dosyalardaki sayfa isimleri hep aynı adı kullanabilir mi?

[konas06]

Günlük satış raporunun alındığı bir klasör düşünelim,
Ancak her yeni gün için rapor alındığında yeni çalışma kitabı oluşuyor ve bu kitap içerisinde sayfa isimleri o günün tarihi ile oluşuyor.

Yapılmak istenen bu klasör içinde olan çalışma kitaplarında bulunan sayfa adlarının aynı olması.
Her kitapta bir sayfa olduğu düşünülmüştür.

Örneğin "SATIŞ"

 

[Korhan Ayhan]

Merhaba,

Bu bahsettiğiniz günlük raporlar nasıl oluşuyor. Oluşurken sorunu kaynağında çözmek daha sağlıklı olacaktır.

 

[konas06]

Korhan bey,
Aslında yapılmak istenen,
Bir klasör içerisinde birden çok kitap var ve her kitapta sadece 1 sayfa var.
Bu sayfaların adları hepsi için aynı olması.

Buradan power quere ye bilgi çekilecek.

 

[Korhan Ayhan]

Deneyiniz.

Dosya yolunu ve sayfa adı tanımlamasını kendi sisteminize göre revize edersiniz.

Option Explicit

Sub Rename_Excel_Sheets()
    Dim My_Connection As Object, All_Tables As Object
    Dim XL_App As Object, My_Path As String
    Dim My_File As String, WB As Object, WS As Object
    Dim New_Sheet_Name As String, Process_Time As Double
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set XL_App = CreateObject("Excel.Application")
    Set My_Connection = CreateObject("AdoDb.Connection")
    Set All_Tables = CreateObject("AdoX.Catalog")
    Set WS = CreateObject("AdoX.Table")
    
    XL_App.Visible = False
    
    New_Sheet_Name = "SATIŞ"
    
    My_Path = "C:\Users\Desktop\Test\"
    
    My_File = Dir(My_Path & "*.xls*")
    
    While My_File <> ""
        My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
        My_Path & My_File & ";Extended Properties=""Excel 12.0;Hdr=No"""
     
        All_Tables.ActiveConnection = My_Connection
    
        For Each WS In All_Tables.Tables
            If Replace(WS.Name, "'", "") Like "*$" And InStr(1, WS.Name, "Print_Area") = 0 Then
                If Replace(Replace(WS.Name, "'", ""), "$", "") = New_Sheet_Name Then
                    If My_Connection.State <> 0 Then My_Connection.Close
                    GoTo 10
                    Exit For
                End If
            End If
        Next
            
        If My_Connection.State <> 0 Then My_Connection.Close
        
        Set WB = XL_App.Workbooks.Open(My_Path & My_File)
        WB.Sheets(1).Name = New_Sheet_Name
        WB.Save
        WB.Close True

10      My_File = Dir
    Wend

    XL_App.Quit
    Set XL_App = Nothing
    Set My_Connection = Nothing
    Set All_Tables = Nothing
    Set WS = Nothing
        
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[konas06]

Deneyiniz.

Dosya yolunu ve sayfa adı tanımlamasını kendi sisteminize göre revize edersiniz.

Option Explicit

Sub Rename_Excel_Sheets()
    Dim My_Connection As Object, All_Tables As Object
    Dim XL_App As Object, My_Path As String
    Dim My_File As String, WB As Object, WS As Object
    Dim New_Sheet_Name As String, Process_Time As Double
   
    Process_Time = Timer
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    Set XL_App = CreateObject("Excel.Application")
    Set My_Connection = CreateObject("AdoDb.Connection")
    Set All_Tables = CreateObject("AdoX.Catalog")
    Set WS = CreateObject("AdoX.Table")
   
    XL_App.Visible = False
   
    New_Sheet_Name = "SATIŞ"
   
    My_Path = "C:\Users\Desktop\Test\"
   
    My_File = Dir(My_Path & "*.xls*")
   
    While My_File <> ""
        My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
        My_Path & My_File & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
        All_Tables.ActiveConnection = My_Connection
   
        For Each WS In All_Tables.Tables
            If Replace(WS.Name, "'", "") Like "*$" And InStr(1, WS.Name, "Print_Area") = 0 Then
                If Replace(Replace(WS.Name, "'", ""), "$", "") = New_Sheet_Name Then
                    If My_Connection.State <> 0 Then My_Connection.Close
                    GoTo 10
                    Exit For
                End If
            End If
        Next
           
        If My_Connection.State <> 0 Then My_Connection.Close
       
        Set WB = XL_App.Workbooks.Open(My_Path & My_File)
        WB.Sheets(1).Name = New_Sheet_Name
        WB.Save
        WB.Close True

10      My_File = Dir
    Wend

    XL_App.Quit
    Set XL_App = Nothing
    Set My_Connection = Nothing
    Set All_Tables = Nothing
    Set WS = Nothing
       
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

Teşekkür ederim.
Emeğinize sağlık.