AW: Daten nach Uhrzeit kopieren
01.12.2008 13:40:20
Wolfgang
Hallo Tino,
vielen Dank für die schnelle Hilfe. Sorry für meine späte Antwort, hänge noch in Thailand fest...auf unbestimmte Zeit :-(. Wie auch immer, mein Lösungsansatz und Gedankengang war etwas anders. Und vermutlich mit der Kirche ums Dorf:-( :
Sub DatenimportSPC()
'Lädt eine Datei in diese Datei und nimmt definierte Stichproben
Dim strFName As String
Dim wkb As Object
Dim intProcessCounter As Integer, intFCount As Integer, intI As Integer
Dim záehler As Integer
Dim Ident As String
Dim Daten2() As Variant
Dim Mappe As Workbook
Dim blatt As String
'Dim i As Long
Dim a As Double, i As Long, anfang As Long
Dim b As Double, j As Integer, anfang2 As Long
Dim intervall As Date, anzahl As Long, z As Integer, summe As Single
Dim j1 As Integer, z1 As Integer, summe1 As Single
Application.ScreenUpdating = False
Sheets("OEE").Select
intervall = Range("h31")
anzahl = Range("h32")
intervall = intervall * 1440
For Each Mappe In Workbooks
blatt = Mappe.Name
Next Mappe
Windows(blatt).Activate
Sheets("Input raw data").Select
' Cells.Select
' Selection.ClearContents 'Delete old data set
Sheets("datenlocation").Select
Range("a2").Select
strFName = ActiveCell
If strFName = "" Then GoTo EndeHier
Do While strFName ""
Workbooks.OpenText Filename:=strFName, _
Origin:=xlMSDOS, StartRow:=2, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=True, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1)), TrailingMinusNumbers:=True
GoTo Teil
Naechste:
Windows(blatt).Activate
Sheets("Input raw data").Select
Cells.Select
Selection.ClearContents 'Delete old data set
Sheets("datenlocation").Select
zaehler = zaehler + 1
strFName = ActiveCell.Offset(zaehler, 0).Value
Loop
If strFName = "" Then GoTo EndeHier
Teil:
Range("a1:ci1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy 'Kopiert rüber
Windows(blatt).Activate
Sheets("Input raw data").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("c1:c10000").Select
Selection.NumberFormat = "dd/mm/yyyy"
Range("d1:d10000").Select
Selection.NumberFormat = "h:mm:ss"
Set wkb = Workbooks.Open(strFName)
wkb.Close savechanges:=False
bsheet = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
'anfang2 = 1
summe = 0
'For j1 = 1 To ActiveSheet.UsedRange.Columns.Count
'If IsNumeric(ActiveCell) Then
'z1 = z1 + 1
'summe = summe + ActiveCell.Value
'Else
'End If
'ActiveCell.Offset(1, 0).Select
'Next j1
For j = 1 To ActiveSheet.UsedRange.Rows.Count
If IsNumeric(ActiveCell) Then
z = z + 1
summe = summe + ActiveCell.Value
Else
End If
ActiveCell.Offset(1, 0).Select
Next j
For i = 1 To Range("d65500").End(xlUp).Row
anfang = i
a = 0
Do
a = a + Format((Cells(i + 1, 4) - Cells(i, 4)) * 1440, "##,##0.00")
i = i + 1
Loop While a j Then 'Versucht die letzte stelle zu definieren
b = j
Else
End If
Range(Cells(i, 1), Cells(b, 78)).Select
Selection.Copy
'Windows(blatt).Activate
Sheets("SPC").Select
Cells(anfang2, 2).Select
Selection.PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
Windows(blatt).Activate
Sheets("Input raw data").Select
Next
z = 0
GoTo Naechste 'EndeHier
EndeHier:
Sheets("Steuerung").Select
Altelauft.Hide
Application.Visible = True
Application.ScreenUpdating = True
Sheets("OEE").Select
End Sub