Toplam 2 sonutan 1 ile 2 arasndakiler gsteriliyor.

Konu: birden ok text dosyasn excelde tek sayfaya alma

  1. #1
    Yeni ye
    yelik tarihi
    Nov 2012
    Mesajlar
    13

    birden ok text dosyasn excelde tek sayfaya alma

    herkese selamlar.arkadalar elimde birden ok text dosyasnn olduu ve herbir text dosyasnnda 4000 ile 6000 satr aras olan bir klasrm mevcut.ayn klasrde olan bu text dosyalarnn tmn makro yardmyla tek bir alma sayfasna alabilirmiyim yardmc olursanz ok sevinirim .

  2. #2
    Yeni ye
    yelik tarihi
    Feb 2017
    Mesajlar
    14
    Corsan75 Bey Merhaba ,

    Sorunuzla alakal ben bir yontem ve bir kod buldum denedim guzel sonuc verdi. Tabi sizin txt dosyalarnzn icindeki verilerin birbiri ile sutun uyumunu bilmiyorum. Deneyin bakalm iinize yarayacak m.

    Text dosyalarnn oldugu klasorun icine yeni bir txt dosyasi acin bu dosyann icine "
    Kod:
     ren *.xtxt *.csv
    yazn ( dosyalarniz xtxt deilde .txt de ise ona gre yazarsnz. ) kayt edip kn. Kayt ettiiniz bu txt dosyasnn uzantsn .bat eklinde deitirin. Cift tklayarak altrn. Ayn dosya iindeki btn xtxt dosyalarnn uzantsnn .csv olarak deitiini greceksiniz..

    yeni bir excel dosyasnda aadaki kodlar yazp altrn tm dosyalarnz tekbir excell de birletirip size nereye hangi isimde kaydettiini gsterecek.


    NOT: klasoruzun yedeini aln csv ye cevirince veri kayb vs olmasn.









    Kod:
    Option Explicit
    
    #If VBA7 Then
        Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
            (ByVal dwDesiredAccess As Long, _
            ByVal bInheritHandle As Long, _
            ByVal dwProcessId As Long) As Long
        
        Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
            (ByVal hProcess As Long, _
            lpExitCode As Long) As Long
    #Else
        Private Declare Function OpenProcess Lib "kernel32" _
            (ByVal dwDesiredAccess As Long, _
            ByVal bInheritHandle As Long, _
            ByVal dwProcessId As Long) As Long
        
        Private Declare Function GetExitCodeProcess Lib "kernel32" _
            (ByVal hProcess As Long, _
            lpExitCode As Long) As Long
    #End If
    
    
    Public Const PROCESS_QUERY_INFORMATION = &H400
    Public Const STILL_ACTIVE = &H103
    
    
    Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
        Dim hProg As Long
        Dim hProcess As Long, ExitCode As Long
        'fill in the missing parameter and execute the program
        If IsMissing(WindowState) Then WindowState = 1
        hProg = Shell(PathName, WindowState)
        'hProg is a "process ID under Win32. To get the process handle:
        hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
        Do
            'populate Exitcode variable
            GetExitCodeProcess hProcess, ExitCode
            DoEvents
        Loop While ExitCode = STILL_ACTIVE
    End Sub
    
    
    Sub Merge_CSV_Files()
        Dim BatFileName As String
        Dim TXTFileName As String
        Dim XLSFileName As String
        Dim FileExtStr As String
        Dim FileFormatNum As Long
        Dim DefPath As String
        Dim Wb As Workbook
        Dim oApp As Object
        Dim oFolder
        Dim foldername
    
        'Create two temporary file names
        BatFileName = Environ("Temp") & _
                "\CollectCSVData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
        TXTFileName = Environ("Temp") & _
                "\AllCSV" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"
    
        'Folder where you want to save the Excel file
        DefPath = Application.DefaultFilePath
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If
    
        'Set the extension and file format
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007 or higher
            FileExtStr = ".xlsx": FileFormatNum = 51
            'If you want to save as xls(97-2003 format) in 2007 use
            'FileExtStr = ".xls": FileFormatNum = 56
        End If
    
        'Name of the Excel file with a date/time stamp
        XLSFileName = DefPath & "MasterCSV " & _
                      Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr
    
        'Browse to the folder with CSV files
        Set oApp = CreateObject("Shell.Application")
        Set oFolder = oApp.BrowseForFolder(0, "Select folder with CSV files", 512)
        If Not oFolder Is Nothing Then
            foldername = oFolder.Self.Path
            If Right(foldername, 1) <> "\" Then
                foldername = foldername & "\"
            End If
    
            'Create the bat file
            Open BatFileName For Output As #1
            Print #1, "Copy " & Chr(34) & foldername & "*.csv" _
                    & Chr(34) & " " & TXTFileName
            Close #1
    
            'Run the Bat file to collect all data from the CSV files into a TXT file
            ShellAndWait BatFileName, 0
            If Dir(TXTFileName) = "" Then
                MsgBox "There are no csv files in this folder"
                Kill BatFileName
                Exit Sub
            End If
    
            'Open the TXT file in Excel
            Application.ScreenUpdating = False
            Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
                    :=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                    ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
                    Space:=False, Other:=False
    
            'Save text file as a Excel file
            Set Wb = ActiveWorkbook
            Application.DisplayAlerts = False
            Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
            Application.DisplayAlerts = True
    
            Wb.Close savechanges:=False
            MsgBox "You find the Excel file here: " & vbNewLine & XLSFileName
    
            'Delete the bat and text file you temporary used
            Kill BatFileName
            Kill TXTFileName
    
            Application.ScreenUpdating = True
        End If
    End Sub

Konu Bilgisi

Users Browsing this Thread

u anda 1 yemiz bu konuya gz atyor. (0 kaytl ye ve 1 misafir.)

Yetkileriniz

  • Konu Acma Yetkiniz Yok
  • Cevap Yazma Yetkiniz Yok
  • Eklenti Ykleme Yetkiniz Yok
  • Mesajnz Deitirme Yetkiniz Yok
  •