19. Mai 2019, 18:42
VB-fun.de - Beitragsübersicht zum VB-/VBA-Forum-Archiv 0413
  E03: Erstellen einer Tab aus zwei Listboxen
 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

[ VB-/VBA-Forum | Archiv 0413 | Archiv-Übersicht ]
 Antworten
E03: Erstellen einer Tab aus zwei Listboxen - zfwez 28. September 2008 um 11:01:24
Re: Erstellen einer Tab aus zwei Listboxen - r.mueller@sz-online.de 10. Oktober 2008 um 00:15:07
Re: Erstellen einer Tab aus zwei Listboxen - zfwez 10. Oktober 2008 um 20:05:46

Zum Seitenanfang

Startseite | VB-/VBA-Tipps | Projekte | Tutorials | API-Referenz | Komponenten | Bücherecke | Gewinnspiele | VB-/VBA-Forum | DirectX | DirectX-Forum | VB.Net | VB.Net-Forum | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum