Option Explicit
Sub import()
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:="TEXT;Z:\result_1.txt", _
Destination:=Range("A1"))
.Name = "result"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveSheet.Name = "eeg"
Dim wrkbook As Workbook
Set wrkbook = ActiveWorkbook
'definieren des workbooks
Dim max_x As Integer
max_x = wrkbook.Worksheets("eeg").UsedRange.Rows.Count
max_x = max_x
'anzahl der zeilen wird ausgelesen
Dim spalte As String
Dim X As Integer
Dim y As Integer
Dim z As Integer
z = 1
Dim a As Variant
Dim b As String
Dim c As String
Do
If z = 1 Then
spalte = "AFREQ_controls"
z = z + 1
ElseIf z = 2 Then
spalte = "AFREQ_cases"
z = z + 1
ElseIf z = 3 Then
spalte = "AFREQ_cc"
z = z + 1
End If
X = 1
y = 0
Do
y = y + 1
Loop Until wrkbook.Worksheets("eeg").Cells(X, y).Value = spalte Or y = 100
'es wird in der ersten Zeile nach gewünschtem Spaltennamen gesucht
X = X + 1
Do
a = Split(wrkbook.Worksheets("eeg").Cells(X, y).Value, "|") 'split-array, "|" ist der Trenner
b = a(0) 'b=erster Teil des arrays "a"
c = a(1) 'c=zweiter Teil des arrays "a"
If b <= "0.01" Or c <= "0.01" Then
wrkbook.Worksheets("eeg").Cells(X, y).Select
Selection.Interior.ColorIndex = 34
X = X + 1
Else
X = X + 1
End If
Loop Until X = max_x + 1
Loop Until z = 4
'programm durchäuft hier zelle um zelle bis es am ende ankommt (max_x = max Zeilenanzahl) und überprüft ob der inhalt < 0,01 oder über 0,99 ist, wenn ja farbliche Markierung
X = 1
y = 1
z = 1
Do
If z = 1 Then
spalte = "HWE_controls"
z = z + 1
ElseIf z = 2 Then
spalte = "HWE_cases"
z = z + 1
ElseIf z = 3 Then
spalte = "HWE_cc"
z = z + 1
End If
X = 1
y = 0
Do
y = y + 1
Loop Until wrkbook.Worksheets("eeg").Cells(X, y).Value = spalte Or y = 100
'es wird in der ersten Zeile nach gewünschtem Spaltennamen gesucht
X = X + 1
Do
If wrkbook.Worksheets("eeg").Cells(X, y).Value <= 0.05 Then
wrkbook.Worksheets("eeg").Cells(X, y).Select
Selection.Interior.ColorIndex = 34
X = X + 1
Else
X = X + 1
End If
Loop Until X = max_x + 1
Loop Until z = 4
'programm durchäuft hier zelle um zelle bis es am ende ankommt (max_x = max Zeilenanzahl) und überprüft ob der inhalt herausfällt, wenn ja farbliche Markierung
X = 1
y = 1
z = 1
Do
If z = 1 Then
spalte = "P_controls"
z = z + 1
ElseIf z = 2 Then
spalte = "P_cases"
z = z + 1
ElseIf z = 3 Then
spalte = "P_cc"
z = z + 1
ElseIf z = 4 Then
spalte = "P_ADD_controls"
z = z + 1
ElseIf z = 5 Then
spalte = "P_ADD_cases"
z = z + 1
ElseIf z = 6 Then
spalte = "P_ADD_cc"
z = z + 1
End If
X = 1
y = 0
Do
y = y + 1
Loop Until wrkbook.Worksheets("eeg").Cells(X, y).Value = spalte Or y = 100
'es wird in der ersten Zeile nach gewünschtem Spaltennamen gesucht
X = X + 1
Do
If wrkbook.Worksheets("eeg").Cells(X, y).Value <= 0.00001 Then
wrkbook.Worksheets("eeg").Cells(X, y).Select
Selection.Interior.ColorIndex = 3
X = X + 1
ElseIf wrkbook.Worksheets("eeg").Cells(X, y).Value <= 0.001 Then
wrkbook.Worksheets("eeg").Cells(X, y).Select
Selection.Interior.ColorIndex = 45
X = X + 1
ElseIf wrkbook.Worksheets("eeg").Cells(X, y).Value <= 0.05 Then
wrkbook.Worksheets("eeg").Cells(X, y).Select
Selection.Interior.ColorIndex = 6
X = X + 1
Else
X = X + 1
End If
Loop Until X = max_x + 1
Loop Until z = 7
'programm durchäuft hier zelle um zelle bis es am ende ankommt (max_x = max Zeilenanzahl) und überprüft ob der inhalt herausfällt, wenn ja farbliche Markierung
Sheets("eeg").Copy 'Blatt in neue Mappe kopieren
With ActiveWorkbook
.SaveAs Filename:="result-test.xls"
.Close
End With
Sheets("eeg").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End Sub
aus mangel an allem, v.a. ahnung ;), hab ich es jetzt so gemacht...
geht das vielleicht auch irgendwie in hübsch und mit dem fso? hab das in meinem makro nicht gebacken bekommen...
gruß falk
|