Soru farklı dosya türlerinde bulunan verileri makro ile birleştirme

Katılım
2 Ağustos 2018
Mesajlar
3
Excel Vers. ve Dili
excel 2016
Herkese merhaba, makro kullanmaya yeni başladım. Aşağıda adım adım belirttiğim soruna yardımcı olabilirseniz çok sevinirim. Şimdiden ilgilenen herkese çok teşekkür ederim.
1. Kayit1=C:\test\1\OutData\Acc48.out dosyasını aç. (3 farklı sütun veri bulunmakta)
2. Kayit2=C:\test\1\EQdat\1_0.1.tcl dosyasını aç. (sadece 1 sütun)
3. Kayit3=C:\test\1\EQdat\1_0.3.tcl dosyasını aç. (sadece 1 sütun)
4. Acc48.out dosyasının 2. sütunu ile 1_0.1.tcl dosyasındaki verileri topla.
5. Acc48.out dosyasının 3. sütunu ile 1_0.3.tcl dosyasındaki verileri topla.
6. Oluşturulan 2 sütunluk yeni veriyi "Absolute Acceleration.txt" dosyasına yaz ve bu dosyayı C:\test\1\OutData klasörünün içine yerleştir.
Bu işlemi test klasörünün içinde yer alan 9600 adet alt klasörler için tekrarla.
Değişken veriler:
1. Klasör numarası 1'den 9600'e kadar
2. EQdat klasörünün içinde yer alan tcl dosya isimleri: 1. klasör için 1_0.1.tcl ve 1_0.3.tcl, 2. klasör için 2_0.1.tcl ve 2_0.3.tcl şeklinde.
Sorun için hazırladım makro kodu:
Sub Makro1()

Dim Kayit1 As String
Dim Kayit2 As String
Dim Kayit3 As String
Dim Kayit4 As String
Dim Klasor1 As String
Dim Klasor2 As String
Dim Klasor3 As String
Dim Dosya1 As String

Application.ScreenUpdating = False

For x = 2 To 7 'birkaç veri üzerinde denemek için

Klasor1 = "C:\test"

Dosya1 = ActiveSheet.Cells(x, 2)
Dosya2 = "OutData"
Dosya3 = "Acc48.out"
Dosya4 = "EQdat"
Dosya5 = ActiveSheet.Cells(x, 6)
Dosya6 = ActiveSheet.Cells(x, 7)
Dosya7 = "Absolute Acceleration.txt"

Application.DisplayAlerts = False

Kayit1 = Klasor1 & "\" & Dosya1 & "\" & Dosya2 & "\" & Dosya3
Kayit2 = Klasor1 & "\" & Dosya1 & "\" & Dosya4 & "\" & Dosya5
Kayit3 = Klasor1 & "\" & Dosya1 & "\" & Dosya4 & "\" & Dosya6


Workbooks.OpenText filename:= _
Kayit1, Origin:= _
857, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False _
, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array _
(3, 1)), TrailingMinusNumbers:=True

Workbooks.OpenText filename:= _
Kayit2, Origin:= _
857, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False _
, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array _
(3, 1)), TrailingMinusNumbers:=True

Workbooks.OpenText filename:= _
Kayit3, Origin:= _
857, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False _
, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array _
(3, 1)), TrailingMinusNumbers:=True


Windows("Acc48.out").Activate
Range("E1").Select
ActiveCell.FormulaR1C1 = "=RC[-3]+'[Dosya5]Dosya5'!.RC[-4]*10"
Range("F1").Select
ActiveCell.FormulaR1C1 = "=RC[-3]+'[Dosya6]Dosya6'!RC[-5]*10"
Range("E1:F1").Select
Selection.AutoFill Destination:=Range("E1:F1", ActiveSheet.Range("E1:F1").End(xlDown))


Workbooks(Dosya5).Close
Workbooks(Dosya6).Close


Dim filename As String, lineText As String
Dim myrng As Range, i, j

filename = Klasor1 & "\" & Dosya1 & "\" & Dosya2 & "\" & Dosya7 ' dosya adresi

Open filename For Output As #1
Set myrng = Range("E1", "F28000") ' kaydedilecek excel bölgesini seç
For i = 1 To myrng.Rows.Count
For j = 1 To myrng.Columns.Count
lineText = IIf(j = 1, "", lineText & " ") & myrng.Cells(i, j)
Next j
Print #1, lineText
Next i
Close #1

Windows("Acc48.out").Activate
ActiveWindow.Close


Next x

End Sub
 
Son düzenleme:

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
Acc48.out, x_0.1.tcl, x_0.3.tcl dosyalarından bir adet örnek ve bu üç dosyadan manuel hazırlayacağınız Absolute Acceleration.txt dosyasını yüklerseniz bakayım.

ancak ben sadece foruma yüklenen dosyalara bakabiliyorum. iş yerinde dosya sitelerine erişimimiz yok maalesef. (evdeki dizüstü bilgisayar da sorunlu, yine maalesef.)
 
Katılım
2 Ağustos 2018
Mesajlar
3
Excel Vers. ve Dili
excel 2016
Acc48.out, x_0.1.tcl, x_0.3.tcl dosyalarından bir adet örnek ve bu üç dosyadan manuel hazırlayacağınız Absolute Acceleration.txt dosyasını yüklerseniz bakayım.

ancak ben sadece foruma yüklenen dosyalara bakabiliyorum. iş yerinde dosya sitelerine erişimimiz yok maalesef. (evdeki dizüstü bilgisayar da sorunlu, yine maalesef.)
Dosya eklemek için sanırım altın üye olmam gerekiyor. Dosya ekleyemiyorum :/
 

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
(kural ihlali olmazsa) imkanı olan bir arkadaşımız o dosyaları buraya ekleyebilir ise çözüm için şansımı deneyeceğim.
 

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
makronun bulunduğu dosyayı ve örneğin ilk 10 klasörü test adında bir klasör altına kopyalayın ve kodu öyle deneyin.
For k = 1 To 9600 kısmını For k = 1 To 10 olarak değiştirerek elbette

txt dosyalarda ondalık ayracı "." olduğundan biraz sorun yaşadım.
bendeki 1 no.lu tek klasörde sorunsuz doyayı üretti.

Kod:
Sub xlTR_174238()

    Dim veriEQ, veriOUT1, veriOUT3, veriAA
    Dim kodSure As String, metinTF As String
    Dim t As Single, i As Long, j As Long, k As Long
    Dim fso As Object, outTF As Object
 
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
       
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
   
    t = Timer

    Set fso = CreateObject("Scripting.FileSystemObject")
   
    For k = 1 To 9600
        Workbooks.OpenText Filename:= _
            ThisWorkbook.Path & "\" & k & "\OutData\Acc48.out", Origin:=1254, StartRow:=1, _
            DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
            Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
            TrailingMinusNumbers:=True
        veriEQ = ActiveSheet.Cells(1).CurrentRegion.Value
        ActiveWorkbook.Close False
   
        Workbooks.OpenText Filename:= _
            ThisWorkbook.Path & "\" & k & "\EQdat\" & k & "_0.1.tcl", Origin:=1254, StartRow:=1, _
            DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
            Tab:=True, Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(1, 1), _
            TrailingMinusNumbers:=True
        veriOUT1 = ActiveSheet.Cells(1).CurrentRegion.Value
        ActiveWorkbook.Close
   
        Workbooks.OpenText Filename:= _
            ThisWorkbook.Path & "\" & k & "\EQdat\" & k & "_0.3.tcl", Origin:=1254, StartRow:=1, _
            DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
            Tab:=True, Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(1, 1), _
            TrailingMinusNumbers:=True
        veriOUT3 = ActiveSheet.Cells(1).CurrentRegion.Value
        ActiveWorkbook.Close
       
        ReDim veriAA(1 To UBound(veriEQ, 1), 1 To 2)
        For j = LBound(veriEQ, 1) To UBound(veriEQ, 1)
            veriAA(j, 1) = veriEQ(j, 2) + veriOUT1(j, 1) * 10
            veriAA(j, 2) = veriEQ(j, 3) + veriOUT3(j, 1) * 10
        Next j

        Set outTF = fso.CreateTextFile(ThisWorkbook.Path & "\" & k & "\OutData\Absolute Acceleration.txt", True)
        For i = 1 To UBound(veriAA, 1)
            For j = 1 To UBound(veriAA, 2)
                metinTF = metinTF & veriAA(i, j) & vbTab '& "," '";"
            Next j
            metinTF = metinTF & vbCrLf
        Next i
        metinTF = Left(metinTF, (Len(metinTF) - 1))
        outTF.WriteLine metinTF
        outTF.Close
    Next k
   
    kodSure = Format((Timer - t) / 86400, "hh:mm:ss")
    MsgBox "İşlemler toplam " & kodSure & " dakikada tamamlandı.", vbInformation

    With Application
        .EnableEvents = True
       
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = True
    End With

End Sub
 
Üst