Klasör içindeki excelleri bir excel kitabında birleştirme

[mesudiye_052]

Merhabalar;

Ekteki klasörün içindeki Esas dosya adlı çalışma kitabındaki makro ile klasörün içindeki csv eklentili excel dosyalarını birleştirebiliyorum

fakat faturalan miktarı kısmını kopyalarken miktarın sonuna 000 sıfır koyarak aktarıyor bu durumun olmaması bire bir aktarmasını istiyorum
Nasıl bir ekleme yapabiliriz.

https://www.dosyaupload.com/rxV3

Saygılarla;

Not: Winrar dosya masaüsüne çıkarınız.

Örnek kod

Sub ImportDataFromMultipleWorkbooks()

Dim vaFiles As Variant
Dim wbkToCopy As Workbook
Dim ws As Worksheet
Dim wsa As Worksheet

ThisWorkbook.Activate

Set ws = Sayfa1

un = "Dear " & Environ("UserName")

ms1 = MsgBox("Do You Want to Import Data from Multiple Workbooks", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
    ws.Range("A2:AA" & Rows.Count).Clear
   
    lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
   
    ChDir (Environ("USERPROFILE") & Application.PathSeparator & "Desktop")
    vaFiles = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", _
    Title:="Select Files to Proceed", MultiSelect:=True)
   
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
   
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
            If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                GoTo skipfile:
            End If
           
           
            Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
           
            Set wa = ActiveWorkbook.ActiveSheet
           
            wa.Range("A1").Select
            wa.Range(Selection, Selection.End(xlDown)).Select
            wa.Range(Selection, Selection.End(xlToRight)).Select
            Selection.Replace What:="", Replacement:=" ", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
            wa.Range("A1").Select
           
            Set wsa = ActiveWorkbook.ActiveSheet
           
            lra = wsa.Cells(Rows.Count, 1).End(xlUp).Row
            lrc = wsa.Cells(1, Columns.Count).End(xlToLeft).Column
           
            For c = 1 To lc
                For ca = 1 To lrc
                    If wsa.Cells(1, ca) = ws.Cells(1, c) Then
                        cn = ca
                        Exit For
                    End If
                Next ca
                For r = 2 To lra
                    y = ws.Cells(Rows.Count, c).End(xlUp).Offset(1, 0).Row
                    If c <> lc Then
                        ws.Cells(y, c) = wsa.Cells(r, cn)
                    Else
                        ws.Cells(y, c) = "FileName: " & Mid(ActiveWorkbook.Name, 1, InStr(1, _
                        ActiveWorkbook.Name, ".csv") - 1)
                    End If
                    y = y + 1
                Next r
            Next c
            wbkToCopy.Close savechanges:=False
skipfile:
        Next i
        ws.Range("A1:AA1").EntireColumn.AutoFit
        ms5 = MsgBox("Data Import Finished", vbInformation, un)
    Else
        ms3 = MsgBox("No Files Selected", vbExclamation, un)
    End If
Else
    ms2 = MsgBox("Cancelled", vbInformation, un)
End If

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub

 

[mesudiye_052]

ChDir (Environ("USERPROFILE") & Application.PathSeparator & "Desktop")
    vaFiles = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", _
    Title:="Select Files to Proceed", MultiSelect:=True)
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
            If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                GoTo skipfile:
            End If
            
            
            Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))

Merhabalar;

Bu durumun olduğu kod bloğu sanırsam aşağıdaki kodlar olsa gerek
ama sorunu çözemiyorum

 

[metehan8001]

Mevcut kullandığın kodun yerine aşağıdaki kodu dener misin ?

Sub ExcelDestek()
Cells.ClearContents
   dsy = Application.GetOpenFilename(FileFilter:="Excel Dosyaları,*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", Title:="Dosya Seç")
    If dsy = "" Or dsy = False Then MsgBox "!...Dosya seçmediniz...!", vbCritical + vbMsgBoxRtlReading, "***************": Exit Sub
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & dsy, Destination:=Range("$A$1"))
        .TextFileStartRow = 1
        .Refresh BackgroundQuery:=False
    End With
Range("J2:J" & Range("A" & Rows.Count).End(xlUp).Row) = Split(dsy, "\")(UBound(Split(dsy, "\")))
MsgBox "...:İşlem Tamam:..." & vbCrLf & vbCrLf & "            Feyzullah / Metehan8001", vbInformation + vbMsgBoxRtlReading, "***************"
End Sub

 

[mesudiye_052]

Merhabalar Metehan;
Teşekkür ederim
Bir ricam klasördeki dosyaları toplu seçerek aktarma yapılabilir mi

 

[mesudiye_052]

Merhabalar
Sayın Metehan;

Klasördeki excelleri birden çok excel dosyasını seçerek bir excel dosyasında birleştirmek istiyorum
sizin gönderdiğiniz makroda sadece 1 tane excel dosyası seçiliyor.


yardımcı olursanız sevinirim.

 

[metehan8001]

Merhabalar
Sayın Metehan;
Klasördeki excelleri birden çok excel dosyasını seçerek bir excel dosyasında birleştirmek istiyorum
sizin gönderdiğiniz makroda sadece 1 tane excel dosyası seçiliyor.
yardımcı olursanız sevinirim.

Sub ExcelDestek()
son = 2: Range("A2:J" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
   dsy = Application.GetOpenFilename(FileFilter:="Excel Dosyaları,*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", Title:="Dosya Seç", MultiSelect:=True)
    If Not IsArray(dsy) Then MsgBox "!...Dosya seçmediniz...!", vbCritical + vbMsgBoxRtlReading, "***************": Exit Sub
For a = LBound(dsy) To UBound(dsy)
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & dsy(a), Destination:=Range("$A$" & Range("A" & Rows.Count).End(xlUp).Row + 1))
        .TextFileStartRow = 2
        .Refresh BackgroundQuery:=False
    End With
Range("J" & son & ":J" & Range("A" & Rows.Count).End(xlUp).Row) = Split(dsy(a), "\")(UBound(Split(dsy(a), "\")))
son = Range("A" & Rows.Count).End(xlUp).Row + 1
Next a
Cells.EntireColumn.AutoFit
MsgBox "...:İşlem Tamam:..." & vbCrLf & vbCrLf & "            Feyzullah / Metehan8001", vbInformation + vbMsgBoxRtlReading, "***************"
End Sub

 

[mesudiye_052]

Merhabalar
Sayın Metehan;

Çok teşekkür ederim.

 

[metehan8001]

Iyi çalışmalar