excelleri birleştirirken isim içerisinde uzantı eklemesin istediğim kod

[euphrates55]

Sub MergeWorkbooks()
Dim xStrPath As String
Dim xStrFName As String
Dim xWS As Worksheet
Dim xMWS As Worksheet
Dim xTWB As Workbook
Dim xStrAWBName As String
On Error Resume Next
xStrPath = "C:\Users\fgunay\Desktop\dt kte\"
xStrFName = Dir(xStrPath & "*.xlsx")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xTWB = ThisWorkbook
Do While Len(xStrFName) > 0
    Workbooks.Open Filename:=xStrPath & xStrFName, ReadOnly:=True
    xStrAWBName = ActiveWorkbook.Name
    For Each xWS In ActiveWorkbook.Sheets
    xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count)
    Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
    xMWS.Name = xStrAWBName
    Next xWS
    Workbooks(xStrAWBName).Close
    xStrFName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

yeni konu açmak istemedim. yine çok uğraşmama rağmen bulamadığım bir durumla karşı karşıyayım. kod ilgili klasördeki tüm excel dosyalarını bir excelde topluyor. isim olarak da dosyanın kendi adını veriyor. sorun ise sonuna .xlsx olarak uzantısını da ekliyor. uzantıyı yazmaması için ve isim 31 karakter sorunundan dolayı 31 karakteri geçiyorsa 31 karaktere kadar yazsın şeklinde kodu nasıl değişebiliriz.

genel olarak, eğer oluyorsa bu birleşme yapılacak klasörü kendimiz seçebilecek hale getirilme şansı var mı?

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodları deneyin.

Sub MergeWorkbooks()
    Dim xStrPath As String
    Dim xStrFName As String
    Dim xWS As Worksheet
    Dim xMWS As Worksheet
    Dim xTWB As Workbook
    Dim xStrAWBName As String
    On Error Resume Next
    xStrPath = "D:\Çarıkçım\Stok Aktarma - Kopya\"
    xStrFName = Dir(xStrPath & "*.xlsx")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set xTWB = ThisWorkbook
    Do While Len(xStrFName) > 0
        Workbooks.Open Filename:=xStrPath & xStrFName, ReadOnly:=True
        xStrAWBName = ActiveWorkbook.Name
        For Each xWS In ActiveWorkbook.Sheets
            xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count)
            Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
            xMWS.Name = Left(Mid(xStrAWBName, 1, WorksheetFunction.Find(".xlsx", xStrAWBName) - 1), 31)
        Next xWS
        Workbooks(xStrAWBName).Close
        xStrFName = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[euphrates55]

Merhaba.

Aşağıdaki kodları deneyin.

Sub MergeWorkbooks()
    Dim xStrPath As String
    Dim xStrFName As String
    Dim xWS As Worksheet
    Dim xMWS As Worksheet
    Dim xTWB As Workbook
    Dim xStrAWBName As String
    On Error Resume Next
    xStrPath = "D:\Çarıkçım\Stok Aktarma - Kopya\"
    xStrFName = Dir(xStrPath & "*.xlsx")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set xTWB = ThisWorkbook
    Do While Len(xStrFName) > 0
        Workbooks.Open Filename:=xStrPath & xStrFName, ReadOnly:=True
        xStrAWBName = ActiveWorkbook.Name
        For Each xWS In ActiveWorkbook.Sheets
            xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count)
            Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
            xMWS.Name = Left(Mid(xStrAWBName, 1, WorksheetFunction.Find(".xlsx", xStrAWBName) - 1), 31)
        Next xWS
        Workbooks(xStrAWBName).Close
        xStrFName = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

kusursuz. teşekkürler...