Von |
zfwez |
eMail |
|
Am |
28. September 2008 um 11:01:24 |
Frage |
Guten Morgen R. Müller, habe gerade "einen Teil Deiner Hausaufgaben" erledigt. Du bist wirklich ein strenger Lehrer! Mit dem Code habe ich wieder ein Problem: er möchte immer wieder die drei Zeitachsen neu erstellen. Hier der Code:Private Sub BtnAuswahl_Click() Dim wksNeu As Worksheet Dim wksTab As Worksheet Dim lngZeile As Long Dim StrZeile As String Dim lngI As Long Dim lngLetzteSpalte As Long Dim lngSpalte As Long Dim lngSpalteNeu As Long Dim rngB As Range Dim vntGesucht As Variant Dim strFirstAddress As String Dim rngGefunden As Range Dim dteD As Date Dim wksTest As Worksheet Dim lngNr As Long Dim TabName As String Dim index As Sheets Dim Name As Sheets Dim TabCount As Integer Dim i As Integer Dim lngTabCount As Long Set wksNeu = ThisWorkbook.Worksheets.Add 'Daten In eine neue Tab schreiben. lngNr = 1 On Error Resume Next Do Set wksTest = Nothing Set wksTest = ThisWorkbook.Worksheets("Ergebnisse_" & CStr(lngNr)) If wksTest Is Nothing Then wksNeu.Name = "Ergebnisse_" & CStr(lngNr) Exit Do End If lngNr = lngNr + 1 Loop On Error GoTo 0 For lngTabCount = 0 To ListBox11.ListCount - 1 If ListBox11.Selected(lngTabCount) Then StrZeile = ListBox11.List(lngTabCount) ' = Quelle Worksheetname Set wksTab = ActiveWorkbook.Worksheets(StrZeile) Application.ScreenUpdating = False 'Achsenbeschriftung In der neuen Tab. '**will immer wieder eine neue Zeitachse erstellen ?!!Nicht Nötig 'ist schon vorhanden 'Erstellung der Zeitachsen wksNeu.Cells(1, 1).Value = "Zeit" wksNeu.Cells(1, 2).Value = "Zeit [sec.]" wksNeu.Cells(1, 3).Value = "Zeit [min.]" wksNeu.Cells(2, 2).Value = 0 wksNeu.Cells(2, 3).Value = 0 wksNeu.Columns(3).NumberFormat = "0.0000" lngSpalteNeu = 3 'Auslesen der Daten und ab der Spalte 3 eintragen For lngI = 0 To ListBox10.ListCount - 1 If ListBox10.Selected(lngI) Then lngZeile = ListBox10.List(lngI, 1) lngLetzteSpalte = wksTab.Cells(lngZeile, wksTab.Columns.Count).End(xlToLeft).Column lngSpalteNeu = lngSpalteNeu + 1 wksNeu.Cells(1, lngSpalteNeu).Value = "Abs" wksNeu.Cells(1, lngSpalteNeu).AddComment 'wksNeu.Cells(1, lngSpalteNeu).Comment.Visible = False 'Kommentar einfügen wksNeu.Cells(1, lngSpalteNeu).Comment.Text Text:=Environ("USERNAME") & Chr(10) _ & "Wavelength (nm)" & Chr(10) & ListBox10.List(lngI, 0) _ & Chr(10) & Date & Chr(10) & wksTab.Name ' gibt den Tabellennamen wieder 'Schrift im Kommentarfeld vergrößern wksNeu.Cells(1, lngSpalteNeu).Comment.Shape.TextFrame.AutoSize = True '******************************************************************** 'Schriftgröße der Kommentares ändern, With wksNeu.Cells(1, lngSpalteNeu).Comment.Shape.TextFrame.Characters.Font .Name = "courier" '"Arial" .Size = 12 .Bold = False .ColorIndex = 32 '3=rot,32 = blau End With wksNeu.Cells(2, lngSpalteNeu).Value = 0 For lngSpalte = 2 To lngLetzteSpalte Step 2 'wksNeu.Cells(lngSpalte / 2 + 2, lngSpalteNeu).Value = wksTab.Cells(lngZeile, lngSpalte).Value wksNeu.Cells(lngSpalte / 2 + 1, lngSpalteNeu).Value = wksTab.Cells(lngZeile, lngSpalte).Value Next End If Next 'Uhrzeit suchen Set rngB = wksTab.Columns(1) vntGesucht = "Collection Time:" Set rngGefunden = rngB.Find(What:=vntGesucht, After:=rngB.Cells(1), LookIn:=xlValues, LookAt:=xlPart) lngZeile = 2 If Not rngGefunden Is Nothing Then strFirstAddress = rngGefunden.Address Do dteD = CDate(Split(rngGefunden.Value, vntGesucht, -1, 1)(1)) wksNeu.Cells(lngZeile, 1).Value = dteD wksNeu.Cells(lngZeile, 1).NumberFormat = "hh:mm:ss" If lngZeile > 2 Then 'Berechnung der Zeitachsen. wksNeu.Cells(lngZeile, 2).FormulaR1C1 = "=ROUND((RC1-R[-1]C1)*86400,0)" 'wksNeu.Cells(lngZeile, 3).FormulaR1C1 = "=ROUND((RC1-R[-1]C1)*1440,4)" wksNeu.Cells(lngZeile, 3).FormulaR1C1 = "=ROUND((RC1-R2C1)*1440,4)" End If lngZeile = lngZeile + 1 Set rngGefunden = rngB.FindNext(rngGefunden) Loop While Not rngGefunden Is Nothing And rngGefunden.Address <> strFirstAddress End If End If 'weitere Tabs , nach Abfrage der Listbox11, durchlaufen 'Next TabCount Set wksNeu = Nothing Set wksTab = Nothing Next Unload Me Application.ScreenUpdating = True End Sub Gruß zfwez |
|