Macro von Sepp verändern

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
TextBox MsgBox
Bild

Betrifft: Macro von Sepp verändern
von: Thomas
Geschrieben am: 28.07.2015 17:38:54

Hallo Excelfreunde,
ich habe mal wieder ein Problem,
Sepp hatt mir vor kurzem dieses macro erstellt. Nun habe ich ein neues Problem dazubekommen ( Zeitformat). Mit diesem coolen Macro kopiere ich bestimmte Zeilen und Spalten in die Auswertungstabelle. Da die Spalten aber unterschiedliche Formate haben wäre es super wenn ich die Spalten und Zeilen im ausgangs Format wieder in die Auswertungstabelle kopieren könnte. Ich habe das schon mit bedingter Formatierung usw. zu lösen versucht aber es will nicht gelingen. Denn die Spalten verändern sich ja ständig.
kann hier jemand helfen?
liebe grüsse Thomas

Sub daten_holen()
  Dim vntData As Variant, vntCrit As Variant, vntRet() As Variant
  Dim vntSpesen As Variant, vntKM As Variant, vntPKM As Variant, vntFahrtart As Variant,  _
vntStunden As Variant, vnteinnahmen As Variant
  Dim date1 As Date, date2 As Date, vntExtra As Variant
  Dim lngRow As Long, lngCol As Long, lngC As Long, lngI As Long, lngN As Long
  Dim bolDoIt As Boolean
  
  On Error GoTo ErrExit
  
  Worksheets("auswertung").Range("b10:ZZ10").ClearContents  '  Formatierung bleibt stehen
Worksheets("auswertung").Range("b11:ZZ10000").ClearContents '  Formatierung mit löschen   _
EntireRow.Delete
  
  
  
  With Sheets("Vorgang")
    vntData = .Range("A1:ek50000")    ' Quellblatt
    
  End With
  
  With Sheets("Daten")
    vntCrit = .Range("b6:el11") ' Spalten buchstaben müssen Gleich gleiche Anzahl haben el11  _
anpassen wenn mehr kritereien
    End With
    
    With Sheets("Filtereinstellungen")
    
    vntSpesen = .Range("h1")
    vntKM = .Range("h2")
    vntPKM = .Range("h3")
    vntFahrtart = .Range("h4")
    vntStunden = .Range("h5")
    vnteinnahmen = .Range("h6")
    date1 = .Range("b18")
    date2 = .Range("b19")
    vntExtra = .Range("b20")
  End With
  
  ReDim vntRet(1 To UBound(vntData, 1), 1 To UBound(vntData, 2))
  
  vntRet(1, 1) = "Datum"
  lngN = 1
  
  For lngCol = 2 To UBound(vntData, 2)
    If vntCrit(1, lngCol - 1) = vntSpesen And _
    vntCrit(2, lngCol - 1) = vntKM And _
      vntCrit(3, lngCol - 1) = vntPKM And _
      vntCrit(4, lngCol - 1) = vntFahrtart And _
      vntCrit(5, lngCol - 1) = vntStunden And _
      vntCrit(6, lngCol - 1) = vnteinnahmen Then
      lngN = lngN + 1
      vntRet(1, lngN) = vntData(1, lngCol)
      lngI = 1
      For lngRow = 2 To UBound(vntData, 1)
      
      
        If vntData(lngRow, 8) >= date1 And vntData(lngRow, 8) <= date2 Then
          bolDoIt = False
          If vntExtra <> "" Then
            For lngC = 2 To UBound(vntData, 2)
            
        '#### gilt wenn auch wortteile gesucht und gefunden werden sollen
        
          'If LCase(vntData(lngRow, lngC)) Like LCase("*" & vntExtra & "*") And
         If vntData(lngRow, lngC) = vntExtra And _
           vntCrit(1, lngC - 1) = vntSpesen And _
            vntCrit(2, lngC - 1) = vntKM And _
            vntCrit(3, lngC - 1) = vntPKM And _
                vntCrit(4, lngC - 1) = vntFahrtart And _
                vntCrit(5, lngC - 1) = vntStunden And _
                vntCrit(6, lngC - 1) = vnteinnahmen Then
                bolDoIt = True
                Exit For
              End If
            Next
          Else
            bolDoIt = True
          End If
          If bolDoIt Then
            lngI = lngI + 1
            vntRet(lngI, 1) = vntData(lngRow, 8)   '  Datumsspalte  8 = H
            vntRet(lngI, lngN) = vntData(lngRow, lngCol)
          End If
        End If
      Next
    End If
  Next
  
  With Sheets("auswertung")
    .Range("b10").Resize(UBound(vntRet, 1), UBound(vntRet, 2)) = vntRet
  End With
  
  
  
  '##########ab hier sortieren nach Datum ''''''''''''''''''''#
  
   ActiveWorkbook.Worksheets("Auswertung").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Auswertung").Sort.SortFields.Add Key:=Range("b11") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Auswertung").Sort
        .SetRange Range("b11:Az1000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  
  
  
  
ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'daten'" & vbLf & String(60, "_") & vbLf & vbLf &  _
_
        IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
 _
        .Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation +  _
_
        vbMsgBoxSetForeground, "VBA - Fehler in Prozedur - daten"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
End Sub

Bild

Betrifft: Macro von Sepp neuer ansatz vieleicht
von: Thomas
Geschrieben am: 29.07.2015 13:31:42
Hallo,
möglicherweise habe ich eine andere Möglichkeit gefunden wie es gehen könnte.
Ich habe mal das untenstehende in ein Textfeld hinterlegt. Dies bewirkt das ich zwar die Uhrzeit als
H:mm eingebe jedoch beim verlassen wird es in 0.00 Format formatiert. Nur leider rechnet excel hier irgend wie komisch bei der Eingabe von z.B. 9:20 wird daraus 9,33 wenn ich jetzt aber die 9,33 wieder zur Zeit umrechne wird daraus 9:19 ( 9,33/24)
Wenn ich dies lösen könnte vielleicht das Makro so bleiben?
Ansonsten habe ich mal mit PasteSpecial Paste:=xlPasteFormats gespielt aber ich denke damit
liege ich völlig daneben.
liebe grüsse thomas

Private Sub TextBox8_Exit(ByVal Cancel As MSForms.ReturnBoolean)
   
    Me.TextBox8 = Format(24 * CDate(TextBox8), "00.00")
End Sub


Bild

Betrifft: AW: Macro von Sepp neuer ansatz vieleicht
von: Andre
Geschrieben am: 30.07.2015 09:16:40
Hallo Thomas,
Das Problem mit der Zeit ist ein Rundungsfehler. 20 Minuten sind Null komma Periode 3 Stunden.
Gruß
Andre

Bild

Betrifft: AW: Macro von Sepp neuer ansatz vieleicht
von: Thomas
Geschrieben am: 30.07.2015 14:03:04
Hallo Andre,
besten dank erstmal für den tipp.
Hast Du auch eine Idee wie man dies lösen könnte?
gruss thomas

Bild

Betrifft: AW: Macro von Sepp neuer ansatz vieleicht
von: Andre
Geschrieben am: 31.07.2015 08:57:17
Hallo Thomas,
Rundungsfehler kannst Du nur vermeiden, wenn Du nicht rundest. Oder benutze möglichst viele Stellen zum Berechnen.
Gruß
Andre

Bild

Betrifft: AW: Macro von Sepp neuer ansatz vieleicht
von: Thomas
Geschrieben am: 31.07.2015 11:03:11
Hallo
besten dank ich probiere mal ein wenig rum.
liebe grüsse thomas

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Macro von Sepp verändern"