Beiträge von Tanto

Hallo Community

Für die Datenbank

eine variable uebernimmt einen wert,keine Formatierung,daher die verfälschte ausgabe

die folgende function korrigiert das Problem

z.b.
=Verbund1(A1;B1;A2) 'Beispiel mit 3 Parameter als verbund,parameteranzahl ist flexibel

Function Verbund1(ParamArray VString() As Variant) As String
For VbT = 0 To UBound(VString)
If IsNumeric(VString(VbT)) = True And InStr(VString(VbT), ",") = 0 Then VString(VbT) = VString(VbT) & ",00"
If IsNumeric(VString(VbT)) = True And InStr(VString(VbT), ",") > 0 And Len(VString(VbT)) - InStr(VString(VbT), ",") = 1 Then VString(VbT) = VString(VbT) & "0"
Verbund1 = Verbund1 & " " & VString(VbT)
Next VbT
End Function

Gruss Tanto

Hallo Community :cool:

Ein Beispiel

Liebe Grüße Tanto :p

Sub Lösch_Zeilen()
    Application.ScreenUpdating = False
    On Error GoTo errExit
    Dim DimAnz As Long
    Dim Country(1) As String
    Country(0) = "Japan"
    Country(1) = "Kazakhstan"
    With ActiveSheet.Columns(1)
        For DimAnz = 0 To UBound(Country, 1)
            .Replace What:=Country(DimAnz), replacement:=True, lookat:=xlWhole
            .SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
        Next DimAnz
    End With
errExit:
    Application.ScreenUpdating = True
End Sub

Hier noch ein Code für einen Begriff

Sub Lösch_Zeilen()
    Application.ScreenUpdating = False
    On Error GoTo errExit
    With ActiveSheet.Columns(1)
            .Replace What:="DeinSuchBegriff", replacement:=True, lookat:=xlWhole
            .SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
    End With
errExit:
    Application.ScreenUpdating = True
End Sub

Hallo Community

Ich denke mal das selbst ein Dicobject nicht unbedingt schneller wäre,hier wären entsprechende Zeitmessungen von Vorteil

Liebe Grüße Tanto :p

Hallo Community :hut:

Zwei mögliche Varianten

Liebe Grüße Tanto :p

Eine mögliche Formel der Zahlenisolierung

=WECHSELN(A2;"kb";"")

Ein Makro der Bereichsaddierung

Einzufügen Alt + F11 /AllgemeinesModul :018:
Die Function ist nun über Function einfügen/Benutzerdefiniert erreichbar

Function SumKb(Zellen As Range) As Long
    Dim Zelle As Range
    Dim EinzelZeichen As Integer
    Dim Schalter As Boolean
    Dim DimIndex As Integer
    Dim RngBereich As Object
    For Each RngBereich In Zellen
        ReDim zaehler2(Len(Cells(RngBereich.Row, RngBereich.Column))) As String
        DimIndex = 1
        For EinzelZeichen = 1 To Len(Cells(RngBereich.Row, RngBereich.Column))
            If Mid(Cells(RngBereich.Row, RngBereich.Column), EinzelZeichen, 1) Like "[0-9,.]" = True Then
                zaehler2(DimIndex) = zaehler2(DimIndex) & Mid(Cells(RngBereich.Row, RngBereich.Column), EinzelZeichen, 1)
                Schalter = True
            End If
            If Schalter = True And Mid(Cells(RngBereich.Row, RngBereich.Column), EinzelZeichen, 1) Like "[0-9,.]" = False Then
                DimIndex = DimIndex + 1
                Schalter = False
            End If
        Next EinzelZeichen
        Schalter = False
        SumKb = SumKb + Val(zaehler2(1))
    Next RngBereich
End Function

Der Ergebnisindex ist der Zeiger auf den jeweiligen Zahlenblock,in diesem falle die 1
Verschiedene Positionen liessen sich leicht über ein ParamArray gestalten :kratz:

Hallo Community :cool:

Ein Beispiel,für einen Automatismus,der das Changeereignis eines Worksheets nutzt

Liebe Güße euer Tanto :p

Einzufügen ist der Code

Alt+F11/Projektexplorer/DeineTabelle

Private Sub worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$W$6" Then
        If UCase(Target) = "X" Then
            Range("Y6").Font.FontStyle = "Fett"
        Else
            Range("Y6").Font.FontStyle = "Fett Kursiv"
        End If
    End If
    Application.EnableEvents = True
End Sub

Hallo Community :p

Hier eine mögliche VB Variante die die Function SummeWenn nutzt

Liebe Grüße euer Tanto

Tabelle1 = Daten
Spalte A = Bezeichner
Spalte B = Zahlen

Tabelle2 = Erstellte Übersicht

Sub Summieren()
        Worksheets(1).Columns("A:A").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Worksheets(1).Columns("A").Copy Worksheets(2).Range("A1")
        Worksheets(1).Columns("A:A").AdvancedFilter Action:=xlFilterInPlace, Unique:=False
        Worksheets(2).Range("B2:B" & Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = "=SUMIF(Tabelle1!RC[-1]:R[7]C[-1],RC[-1],Tabelle1!RC:R[7]C)"
End Sub

Hallo Community

Angepasste Variante wäre das

Liebe Grüße Tanto :razz:

Sub FilterKopieren()
    Worksheets("Übersicht").Range("H1").AutoFilter Field:=1, Criteria1:=1
    Worksheets("Übersicht").Rows("2:" & Worksheets("Übersicht").UsedRange.SpecialCells(xlCellTypeLastCell).Row).Copy Worksheets("Teilnetz_1_OS_Glis").Range("A" & Worksheets("Teilnetz_1_OS_Glis").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    Worksheets("Übersicht").Range("H1").AutoFilter
End Sub

Hallo Community

Eine Variante wäre das

Liebe Grüße Tanto :p

Sub FilterKopieren()
    Worksheets("Tabelle1").Range("A1").AutoFilter Field:=1, Criteria1:=1
    Worksheets("Tabelle1").Rows("2:" & Worksheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row).Copy Worksheets("Tabelle2").Range("A" & Worksheets("Tabelle2").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    Worksheets("Tabelle1").Range("A1").AutoFilter
End Sub

Hallo Kiesel

Daten Selectieren
Bearbeiten/Kopieren
Bearbeiten/Inhalte einfügen/Reiter setzen bei Transponieren

Liebe Grüße Tanto :p

Hallo Katze :cool:

Selectiere nur den genutzen Bereich

Liebe Grüße Tanto :p

Hallo Community

Probier das mal

Liebe Grüße Tanto :p

If Mid(CStr(Cells(anzahl, 2)), 1, 6) = "Fehler" Then

Hallo Community

Ersetze den Laufwerksbuchstaben durch den Laufwerksnamen

Liebe Grüße Tanto :p

Hallo Community

Ein Beispiel

Liebe Grüße Tanto :p

=(24-A1)+B1

Hallo Michael

Die Variable WksWert wurde den Erfordernissen angepasst,vom Datentyp Long auf Double geändert

Liebe Grüße Tanto :p

Function WksWert(Zellen As Range, FarbIndex As Long) As Double
    Dim Zelle As Range
    For Each Zelle In Zellen
        If Cells(Zelle.Row, Zelle.Column).Interior.ColorIndex = FarbIndex Then
            WksWert = WksWert + Cells(Zelle.Row, Zelle.Column)
        End If
    Next Zelle
End Function

Hallo Michael

Eine Variante wäre ein AddInn

Liebe Grüße Tanto :p

1. In eine leere Mappe ist der ausgewählte Code einzufügen
2. Clicken Sie im Menü Datei auf Speichern unter
3. Als Dateityp ist Microsoft Excel-Add-Inn einzustellen und ein Eindeutiger Name für das zukünftige AddInn
4. Clicken Sie auf Extras/Add-Inns-Manager und setzen das Häckchen bei ihrem AddInn
5. Nun steht die Funktion für Excel Global bereit

Sollte sich eine beliebige Function nicht Aktualisieren,dann diese mit folgenden Code ergänzen(Erste Zeile)

Application.Volatile

• Zeigen Sie im Menü Extras von Microsoft Excel auf Makro, und klicken Sie dann auf Visual Basic-Editor.
• Klicken Sie im Menü Einfügen auf Modul.
• Geben Sie Ihren Code in das Codefenster des Moduls ein, oder kopieren Sie ihn hinein.
• Zeigen Sie im Visual Basic-Editor-Menü von Microsoft Excel auf Datei, und klicken Sie dann auf Schließen und zurück zu Microsoft Excel
• Fügen Sie nun die Benutzerdifinierte Function in eine Zelle ein
• z.b. = WksWert(A1:A100;3)
• Der Suchbereich wäre bei diesem Beispiel Zelle A1 bis Zelle A100,der Farbindex 3 steht für Rot

Hallo Community

Hoffe es ist nun verständlicher

Liebe Grüße Tanto :p

Hallo Michael

Wie gewünscht

Liebe Grüße Tanto :p

Die Function ist Alt+F11/Projektexplorer/AllgemeinesModul einzufügen

Syntax
= WksWert(Bereich,GesuchterFarbIndex)

Function WksWert(Zellen As Range, FarbIndex As Long) As Long
    Dim Zelle As Range
    For Each Zelle In Zellen
        If Cells(Zelle.Row, Zelle.Column).Interior.ColorIndex = FarbIndex Then
            WksWert = WksWert + Cells(Zelle.Row, Zelle.Column)
        End If
    Next Zelle
End Function

Hallo Kiesel :p

Die zu sortierenden Daten sind Spalte A und Spalte B ist eine Hilfsspalte die ausgeblendet sein sollte

Liebe Grüße Tanto

Sub SortierenCrit1_Crit2()
    Dim Lzeile As Long
    Lzeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Range("A1:A" & Lzeile).Copy Range("B1:B" & Lzeile)
    Range("B1:B" & Lzeile).Replace What:="*_", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1"), _
    Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("B1:B" & Lzeile).Clear
End Sub

Hallo Community

Konnte leider nicht weiter helfen,da ich kein excel7 besitze und die Datei dadurch nicht lesbar war 8O

Liebe grüße Tanto :p

Hallo Victor :cool:

Vielleich ist das Makro an der falschen Position,es muss hier eingefügt werden für den Automatismus

Alt+F11/Projektexplorer/DeineTabelle

Solltest Du nicht zurecht kommen,dann schau bitte in dein Postfach zum Emailaustausch

Das Ergebnis poste ich dann zu angemessener Zeit

Liebe Grüße Tanto :p

Hallo Victor

Cells(DeineZeile, DeineSpalte)

für E25 also folgendermaßen

Cells(25,5)

Liebe Grüße Tanto :p