Call GetImportData
'am Schluss immer Objektvariablen löschen mit:
Set objFileDialog = Nothing
End Sub
Sub CheckFileNumbers()
Range("A5").Select
intSourceEndzeile = ActiveSheet.UsedRange.Rows.Count - 1
For intZähler = 1 To intSourceEndzeile
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value > 199 Then
intSourceStartzeile = ActiveCell.Row
intFileNumber = ActiveCell.Value
Exit For
End If
Next
'allfällige Meldungen unterdrücken ...
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "O:\R&T 43\_Fungicide Profiling\Logistik AIRIM\Greenhouse Reports\Screening Operation\TempFiles\" & intFileNumber & ".xls"
ActiveWorkbook.Close
'Windows(strSourceFile).Activate
'ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Sub GetImportData()
'Objektvariable für das FileSystemObjekt definieren:
Set fso = New FileSystemObject
Set vrz = fso.GetFolder(varFolders)
intFileZähler = 0
ChDir varFolders
For Each fle In vrz.Files
Workbooks.Open fle.Name
strSourceFile = ActiveWorkbook.Name
intFileZähler = intFileZähler + 1
'Startposition im SourceFile ...
Range("A5").Select
intSourceEndzeile = ActiveSheet.UsedRange.Rows.Count - 1
For intZähler = 1 To intSourceEndzeile
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value > 199 Then
intSourceStartzeile = ActiveCell.Row
intFileNumber = ActiveCell.Value
Exit For
End If
Next
'Datenimport 1. Bereich markieren ...
Range("A" & intSourceStartzeile & ":F" & intSourceEndzeile).Select
'Markierter Bereich kopieren ...
Selection.Copy
'Wechsel zu Zieldatei ...
Windows(strTargetFile).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Wechsel wieder zu Quelldatei ...
Windows(strSourceFile).Activate
'... Zeile 5 und 6 Zellen verbinden aufheben!
Rows("5:6").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.UnMerge
Range("G6").Select
'------------------------------------------------
'... nun noch die vorhandenen Spalten zählen ...
intSpaltenZähler = 0
Range("G6").Select
For intZähler = 1 To 10 '= max. Anzahl Spalten!
If ActiveCell.Value <> "" Then
intSpaltenZähler = intSpaltenZähler + 1
ActiveCell.Offset(0, 1).Select
Else
Exit For
End If
Next
'----------------------------------------------------------------------
'... wenn "AgroDil Remark" vorhanden wird zuerst diese Spalte gelöscht!
Range("G6").Select
intZähler = 0
For intZähler = 1 To 10 '= max. Anzahl Spalten!
If ActiveCell.Value = "AgroDil Remark" Then
Columns(ActiveCell.Column).Select
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(intSourceEndzeile, ActiveCell.Column)).Select
Selection.Delete Shift:=xlToLeft
Exit For
Else
ActiveCell.Offset(0, 1).Select
End If
Next
'---------------------------------------------------------------------
'Spaltentitel kopieren ...
'Wechsel wieder zu Quelldatei ...
Windows(strSourceFile).Activate
Range("G5").Select
strModulname = ActiveCell.Value
intPosModulname = InStr(1, strModulname, "_")
strModulname = Mid(strModulname, intPosModulname + 1, Len(strModulname) - intPosModulname)
'Wechsel zu Zieldatei ...
Windows(strTargetFile).Activate
If intFileZähler = 1 Then
Range(Cells(9, 7), Cells(9, 7)).Select
Else
Range(Cells(9, 7 + ((intFileZähler - 1) * 9)), Cells(9, 7 + ((intFileZähler - 1) * 9))).Select
End If
'Range("G9").Select
ActiveCell.Value = strModulname
Range(ActiveCell, ActiveCell(1, 9)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
'Wechsel wieder zu Quelldatei ...
Windows(strSourceFile).Activate
Range(Cells(6, 7), Cells(6, 7 + (intSpaltenZähler - 2))).Select
Selection.Copy
'Wechsel zu Zieldatei ...
Windows(strTargetFile).Activate
If intFileZähler = 1 Then
Range(Cells(10, 7), Cells(10, 7)).Select
Else
Range(Cells(10, 7 + ((intFileZähler - 1) * 9)), Cells(10, 7 + ((intFileZähler - 1) * 9) + (intSpaltenZähler - 1))).Select
End If
'Cells(10, 7).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'-------------------------------------
'Datenimport 2. Bereich markieren ...
'Wechsel wieder zu Quelldatei ...
Windows(strSourceFile).Activate
Range(Cells(intSourceStartzeile, 7), Cells(intSourceEndzeile, 7 + (intSpaltenZähler - 2))).Select
'
'Markierter Bereich kopieren ...
Selection.Copy
'Wechsel zu Zieldatei ...
Windows(strTargetFile).Activate
If intFileZähler = 1 Then
Range(Cells(intTargetStartzeile, 7), Cells(intTargetStartzeile, 7)).Select
Else
Range(Cells(intTargetStartzeile, 7 + ((intFileZähler - 1) * 9)), Cells(intTargetStartzeile, 7 + ((intFileZähler - 1) * 9))).Select
End If
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Windows(strSourceFile).Activate
'allfällige Meldungen unterdrücken ...
Application.DisplayAlerts = False
ActiveWorkbook.Close
'Windows(strSourceFile).Activate
'ActiveWorkbook.Close
Application.DisplayAlerts = True
GetStartpunkt
Next
End Sub