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
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: