Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 21:09:11
4 Spalten aus smarter Tabelle in andere smarte Tab. kopieren
18.04.2024 20:45:35
Worksheet_Activate für alle Sheets
18.04.2024 19:30:20
VBA - Tabelle mit Mannschaftsergebnissen sortieren
18.04.2024 18:04:29
Formel fehler Wert#
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1580to1584
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1580to1584
1580to1584
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Eine Funktion auf mehrere Zellen anwenden

Eine Funktion auf mehrere Zellen anwenden
15.09.2017 01:32:39
Siggi
Hallo zusammen,
Ich habe einen Code geschrieben,
man drückt auf den Button,
und in der "Tabelle A" wird überprüft ob auf einer bestimmten Zelle, hier "C8" eine Zahl größer 0 eingegeben wurde,
dann liefert dieses Code 3 andere Zellen aus "Tabelle A" in ein Arbeitsblatt Namens "Auszug".

  • Sub NeuesArbeitsblat_Auszug()
'Löscht das Arbeitsblatt "Auszug"
On Error Resume Next
Worksheets("Auszug").Delete
On Error GoTo 0
'Neues Arbeitsblatt namens "Auszug" wird als eine Kopie von Arbeitsblatt "Muster" erstellt :
ThisWorkbook.Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Auszug"
'*** Stammdaten Anfang
Set Auszug = Sheets("Auszug")
Set TB1 = Sheets("Tabelle A")
'Prüft ob die Prüfzelle eine Zahl ist und größer als 0 ist
'Dann werden die dazuentsprechende Zellen mitkopiert in den Auszug
If IsNumeric(TB1.Cells(8, 3)) And TB1.Cells(8, 3) > 0 Then
'Beschriftung und Info werden übertragen
Auszug.Cells(8, 1) = TB1.Cells(6, 1)
Auszug.Cells(9, 1) = TB1.Cells(7, 1)
'Schriftgröße für Beschrigftung und Info sollte übertragen werden
'Zellen inhalt wird übertragen
Auszug.Cells(10, 1) = TB1.Cells(8, 1)
Auszug.Cells(10, 2) = TB1.Cells(8, 2)
Auszug.Cells(10, 3) = TB1.Cells(8, 6)
'Format mitübertragen
Auszug.Cells(10, 1).NumberFormat = TB1.Cells(8, 1).NumberFormat
Auszug.Cells(10, 2).NumberFormat = TB1.Cells(8, 2).NumberFormat
Auszug.Cells(10, 3).NumberFormat = TB1.Cells(8, 6).NumberFormat
'Rahmen setzen
Auszug.Cells(10, 1).Borders(xlEdgeLeft).LineStyle = xlContinuous
Auszug.Cells(10, 1).Borders(xlEdgeTop).LineStyle = xlContinuous
Auszug.Cells(10, 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
Auszug.Cells(10, 2).Borders(xlEdgeTop).LineStyle = xlContinuous
Auszug.Cells(10, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
Auszug.Cells(10, 3).Borders(xlEdgeTop).LineStyle = xlContinuous
Auszug.Cells(10, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous
Auszug.Cells(10, 3).Borders(xlEdgeRight).LineStyle = xlContinuous
End If
MsgBox "        Neues Auszug ist erstellt!"
End Sub

    • Jetzt möchte ich gerne, dass dieses Verfahren auch auf die restliche Zelen in in dieser Spalte angewendet wird, also ab zeile 8.
    Wie geht das am einfachsten?
    Habe schon mehrmals versucht was einzugeben , bin aber gescheitert : (
    Und die zweite Frage gleich, wie kann man denn die Schriftgröße übertragen, so in etwa wie ich das .NumberFormat mitübertragen konnte?
    https://www.herber.de/bbs/user/116252.xlsm

    15
    Beiträge zum Forumthread
    Beiträge zu diesem Forumthread

    Betreff
    Datum
    Anwender
    Anzeige
    AW: Eine Funktion auf mehrere Zellen anwenden
    15.09.2017 11:28:30
    ChrisL
    Hi
    Die Schriftgrösse alleine kannst du nicht übernehmen (Theoretisch kann jeder Buchstaben eine andere Grösse haben). Entweder übernimmst du alle Formatierungen und löschst dann nachträglich z.B. die Farben. Oder du schaust halt welche Grösse der erste Buchstaben hat und wendest es dann auf alles an. Ich bin kein Fan von Formatierungs-Schnickschnack.
    Für den Rest hier ein Beispielcode:
    Sub Mach()
Dim WS1 As Worksheet: Set WS1 = Worksheets("Tabelle A")
Dim WS2 As Worksheet
Dim lngZeile As Long, lngLetzteZeile As Long
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Auszug").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
WS2.Name = "Auszug"
With WS1
lngLetzteZeile = .Cells(Rows.Count, 3).End(xlUp).Row
If lngLetzteZeile " & 0) = 0 Then Exit Sub
WS2.Cells(8, 1) = .Cells(6, 1)
WS2.Cells(9, 1) = .Cells(7, 1)
For lngZeile = 8 To lngLetzteZeile
If .Cells(lngZeile, 3) > 0 Then Call CopyZeile(WS1, WS2, lngZeile)
Next lngZeile
End With
End Sub


    Private Sub CopyZeile(WS1 As Worksheet, WS2 As Worksheet, lngZeile As Long)
Dim lngLetzteZeile As Long
lngLetzteZeile = WS2.Cells(Rows.Count, 1).End(xlUp).Row + 1
With WS2
'Zellen inhalt wird übertragen
.Cells(lngLetzteZeile, 1) = WS1.Cells(lngZeile, 1)
.Cells(lngLetzteZeile, 2) = WS1.Cells(lngZeile, 2)
.Cells(lngLetzteZeile, 3) = WS1.Cells(lngZeile, 6)
'Format mitübertragen
.Cells(lngLetzteZeile, 1).NumberFormat = WS1.Cells(lngZeile, 1).NumberFormat
.Cells(lngLetzteZeile, 2).NumberFormat = WS1.Cells(lngZeile, 2).NumberFormat
.Cells(lngLetzteZeile, 3).NumberFormat = WS1.Cells(lngZeile, 6).NumberFormat
'Rahmen setzen
.Cells(lngLetzteZeile, 1).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 1).Borders(xlEdgeTop).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 2).Borders(xlEdgeTop).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 3).Borders(xlEdgeTop).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 3).Borders(xlEdgeRight).LineStyle = xlContinuous
End With
End Sub
    cu
    Chris
    Anzeige
    Danke schön!
    15.09.2017 15:41:15
    Siggi
    Vielen Dank für deine Antwort,
    es funktioniert super!!!
    Und mit der Schriftgröße bin ich jetzt auch selber klargekommen : )
    Ich habe da noch paar Sachen eingebaut, wie verkettung von zwei zellen.
    Ich komme langsam doch ans Ziel,
    doch es bleibt einer der schwierigsten Aufgaben,
    wo ich noch mal um Hilfe bitten würde!
    Ich muss jetzt diesen Code auf mehrere Tabellen anwenden.
    Hier im Beispiel sind es "Tabelle A", "Tabelle B" und "Tabelle C".
    Bisherige Code
  • Sub Mach()
    Dim WS1 As Worksheet: Set WS1 = Worksheets("Tabelle A")
    Dim WS2 As Worksheet
    Dim lngZeile As Long, lngLetzteZeile As Long
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Auszug").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    ThisWorkbook.Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
    Set WS2 = ActiveSheet
    WS2.Name = "Auszug"
    With WS1
    lngLetzteZeile = .Cells(Rows.Count, 3).End(xlUp).Row
    If lngLetzteZeile If WorksheetFunction.CountIf(.Range("C8:C" & lngLetzteZeile), ">" & 0) = 0 Then Exit Sub
    ' Beschriftung und Info Verketten
    WS2.Cells(8, 1) = .Cells(6, 1) + " " + .Cells(7, 1)
    ' Schriftgröße von Info und von Beschriftung ändern
    WS2.Cells(8, 1).Font.Size = .Cells(7, 1).Font.Size
    ' Schriftgröße von Beschriftung ändern
    Dim i As Integer
    i = InStr(1, WS2.Cells(8, 1), " ") - 1
    WS2.Cells(8, 1).Characters(1, i).Font.Size = .Cells(6, 1).Font.Size
    ' Info extra übertragen
    WS2.Cells(9, 1) = .Cells(5, 8)
    For lngZeile = 8 To lngLetzteZeile
    If .Cells(lngZeile, 3) > 0 Then Call CopyZeile(WS1, WS2, lngZeile)
    Next lngZeile
    End With
    End Sub 
    Private Sub CopyZeile(WS1 As Worksheet, WS2 As Worksheet, lngZeile As Long)
Dim lngLetzteZeile As Long
lngLetzteZeile = WS2.Cells(Rows.Count, 1).End(xlUp).Row + 1
With WS2
'Zellen inhalt wird übertragen
.Cells(lngLetzteZeile, 1) = WS1.Cells(lngZeile, 1)
.Cells(lngLetzteZeile, 2) = WS1.Cells(lngZeile, 2)
.Cells(lngLetzteZeile, 3) = WS1.Cells(lngZeile, 6)
'Format mitübertragen
.Cells(lngLetzteZeile, 1).NumberFormat = WS1.Cells(lngZeile, 1).NumberFormat
.Cells(lngLetzteZeile, 2).NumberFormat = WS1.Cells(lngZeile, 2).NumberFormat
.Cells(lngLetzteZeile, 3).NumberFormat = WS1.Cells(lngZeile, 6).NumberFormat
'Schriftgröße übertragen
.Cells(lngLetzteZeile, 1).Font.Size = WS1.Cells(lngZeile, 1).Font.Size
.Cells(lngLetzteZeile, 2).Font.Size = WS1.Cells(lngZeile, 2).Font.Size
.Cells(lngLetzteZeile, 3).Font.Size = WS1.Cells(lngZeile, 6).Font.Size
'Rahmen setzen
.Cells(lngLetzteZeile, 1).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 1).Borders(xlEdgeTop).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 2).Borders(xlEdgeTop).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 3).Borders(xlEdgeTop).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Cells(lngLetzteZeile, 3).Borders(xlEdgeRight).LineStyle = xlContinuous
End With
End Sub

    • Ausgangsdaten:
    Tabelle A:
    Userbild
    Tabelle B:
    Userbild
    Tabelle C:
    Userbild
    Und das hier wäre mein Traum-Auszug =)
    Userbild
    Hier ist die Excel-datei:
    https://www.herber.de/bbs/user/116274.xlsm
    Und ich hätte noch eine kleine bitte,
    kann man es so programmieren,
    dass VBA die Daten für den Auszug nicht aus den Arbeitblättern: "Tabelle A","Tabelle B" und "Tabelle C" entnimmt,
    sondern aus allen Arbeitsblättern in dieser Datei außer den folgenden Arbeitsblättern: "Übersicht", "Muster", "Traum-Auszug".
    Es müsste ja denselben Ergebnis liefern.
    Es wäre aber fantastisch, wenn das gehen würde!
    Dann könnte ich beliebig viele Arbeitblätter einfügen, und diese würden dann automatisch miteinbezogen.
    Danke!!
    Anzeige
    Ansatz
    15.09.2017 17:58:28
    ChrisL
    Hi
    Ich muss leider gleich los, darum nur noch kurz die Systematik...
    Sub Mach()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim lngZeile As Long, lngLetzteZeile As Long
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Auszug").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
WS2.Name = "Auszug"
For Each WS1 in ThisWorkbook.Worksheets
If WS1.Name  "Übersicht" and WS1.Name  "Muster" Then
lngLetzteZeile = .Cells(Rows.Count, 3).End(xlUp).Row
If lngLetzteZeile " & 0) = 0 Then Resume Next
WS2.Cells(lngLetzteZeile + 1, 1) = .Cells(6, 1)
WS2.Cells(lngLetzteZeile + 2, 1) = .Cells(7, 1)
For lngZeile = 8 To lngLetzteZeile
If .Cells(lngZeile, 3) > 0 Then Call CopyZeile(WS1, WS2, lngZeile)
Next lngZeile
End If
Next WS1
End Sub

    Alles was die Formatierung der Zeilen (Datensätze) ohne Titel betrifft, sollte in die Unterprozedur "CopyZeile".
    cu
    Chris
    Anzeige
    AW: Ansatz
    15.09.2017 18:00:44
    ChrisL
    Hi nochmal
    Noch ein Überlegungsfehler mit der letzten Zeile...
    Sub Mach()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim lngZeile As Long, lngLetzteZeile As Long
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Auszug").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
WS2.Name = "Auszug"
For Each WS1 in ThisWorkbook.Worksheets
If WS1.Name  "Übersicht" and WS1.Name  "Muster" Then
lngLetzteZeile = .Cells(Rows.Count, 3).End(xlUp).Row
If lngLetzteZeile " & 0) = 0 Then Resume Next
lngLetzteZeile = WS2.Cells(Rows.Count, 3).End(xlUp).Row
WS2.Cells(lngLetzteZeile + 1, 1) = .Cells(6, 1)
WS2.Cells(lngLetzteZeile + 2, 1) = .Cells(7, 1)
For lngZeile = 8 To lngLetzteZeile
If .Cells(lngZeile, 3) > 0 Then Call CopyZeile(WS1, WS2, lngZeile)
Next lngZeile
End If
Next WS1
End Sub

    Anzeige
    Fehler beim Kompilieren
    16.09.2017 00:57:45
    Siggi
    Es ergibt bei mir ein Fehler
    Userbild
    und ich weiß nicht woran es liegt,
    kannst du es bitte testen ob es bei dir funktioniert ?
    AW: Fehler beim Kompilieren
    16.09.2017 08:02:05
    ChrisL
    Mein Fehler...
    Sub Mach()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim lngZeile As Long, lngLetzteZeile As Long
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Auszug").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
WS2.Name = "Auszug"
For Each WS1 in ThisWorkbook.Worksheets
With WS1
If .Name  "Übersicht" and .Name  "Muster" Then
lngLetzteZeile = .Cells(Rows.Count, 3).End(xlUp).Row
If lngLetzteZeile " & 0) = 0 Then Resume Next
lngLetzteZeile = WS2.Cells(Rows.Count, 3).End(xlUp).Row
WS2.Cells(lngLetzteZeile + 1, 1) = .Cells(6, 1)
WS2.Cells(lngLetzteZeile + 2, 1) = .Cells(7, 1)
For lngZeile = 8 To lngLetzteZeile
If .Cells(lngZeile, 3) > 0 Then Call CopyZeile(WS1, WS2, lngZeile)
Next lngZeile
End If
End With
Next WS1
End Sub

    Anzeige
    Laufzeitfehler ..
    16.09.2017 18:17:18
    Siggi
    Es kommt jetzt ein anderes Fehler
    Userbild
    AW: Laufzeitfehler ..
    18.09.2017 08:36:08
    ChrisL
    Hi
    Ja sorry, da habe ich ziemlich daneben gehauen. Jetzt sollte es funktionieren...
    Sub Mach()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim lngZeile As Long, lngLetzteZeile1 As Long, lngLetzteZeile2 As Long
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Auszug").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
WS2.Name = "Auszug"
For Each WS1 In ThisWorkbook.Worksheets
With WS1
If .Name  "Übersicht" And .Name  "Muster" And .Name  "Auszug" Then
lngLetzteZeile1 = .Cells(Rows.Count, 3).End(xlUp).Row
If lngLetzteZeile1 > 7 Then
If WorksheetFunction.CountIf(.Range("C8:C" & lngLetzteZeile1), ">" & 0) > 0 Then
lngLetzteZeile2 = WS2.Cells(Rows.Count, 3).End(xlUp).Row
If lngLetzteZeile2  0 Then Call CopyZeile(WS1, WS2, lngZeile)
Next lngZeile
End If
End If
End If
End With
Next WS1
End Sub
    cu
    Chris
    Anzeige
    AW: Laufzeitfehler ..
    18.09.2017 10:22:41
    Siggi
    Viel Dank ChrisL!
    es sammelt die Info von allen Tabellen.
    Kannst du bitte nur noch den letzten Schritt einbauen,
    dass die Tabellen richtig angezeigt werden?
    Also das bekomme ich jetzt raus:
    Userbild
    Und das ist das wünschenswerte Auszug:
    Userbild
    Das ganze Formatierung bekomme ich später auch selber hin,
    aber die Reihenfolge der Zellen.. da bin ich leider noch nicht so weit.
    https://www.herber.de/bbs/user/116317.xlsm
    Anzeige
    Neustart
    18.09.2017 13:37:36
    ChrisL
    Hi
    Vergiss alle bisherigen Codes. Aufgrund der Datenstruktur wird das alles ziemlich aufwändig. Erstmal müssen die Daten in eine Datenbank-ähnliche Struktur gebracht werden (Array/Datenfeld). Dann sortieren, dann das Array durchlaufen und die Zwischentitel einfügen.
    Sortieren habe ich ausnahmsweise via Hilfstabelle gelöst (bei den Sort-Algorithmen ist mir kurz mal die Geduld ausgegangen). 
    Sub MachNochmal()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim lngLetzteZeile As Long, lngZeile As Long
Dim lngCounter As Long, strTitel As String
' Tabelle neu anlegen
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Auszug").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
WS2.Name = "Auszug"
' Rohdaten in Array einlesen
Application.ScreenUpdating = False
For Each WS1 In ThisWorkbook.Worksheets
With WS1
If .Name  "Übersicht" And .Name  "Muster" And .Name  "Auszug" Then
lngLetzteZeile = .Cells(Rows.Count, 3).End(xlUp).Row
If lngLetzteZeile > 7 Then
For lngZeile = 6 To lngLetzteZeile
If .Cells(lngZeile, 1)  "" And _
WorksheetFunction.CountBlank(.Range(.Cells(lngZeile, 2), .Cells(lngZeile, 6))) = 5 Then
strTitel = .Cells(lngZeile, 1) & " " & .Cells(lngZeile + 1, 1)
lngZeile = lngZeile + 1
End If
If .Cells(lngZeile, 3) > 0 Then
If lngCounter = 0 Then ReDim arrDaten(0 To 4, 0 To 0) Else _
ReDim Preserve arrDaten(0 To 4, 0 To lngCounter)
arrDaten(0, lngCounter) = strTitel
arrDaten(1, lngCounter) = .Range("H5")
arrDaten(2, lngCounter) = .Cells(lngZeile, 1)
arrDaten(3, lngCounter) = .Cells(lngZeile, 2)
arrDaten(4, lngCounter) = .Cells(lngZeile, 6)
lngCounter = lngCounter + 1
End If
Next lngZeile
End If
End If
End With
Next WS1
If lngCounter = 0 Then Exit Sub
' Daten zwecks Sortierung in Hilfstabelle und Hilfstabelle wieder löschen
Set WS3 = Worksheets.Add
With WS3
.Range("A1:E" & lngCounter - 1) = Application.Transpose(arrDaten)
With .Sort
.SortFields.Clear
.SortFields.Add Key:=WS3.Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
.SetRange Range("A1:E" & lngCounter - 1)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Daten zurück in Array und Tabelle wieder löschen
arrDaten = Application.Transpose(.Range("A1:E" & lngCounter - 1).Value)
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
' Ergbnis aus Array übertragen
lngCounter = 1
lngZeile = 8
With WS2
Do While lngCounter  arrDaten(1, lngCounter - 1) Or _
arrDaten(2, lngCounter)  arrDaten(2, lngCounter - 1) Then
.Cells(lngZeile + 1, 1) = arrDaten(1, lngCounter)
.Cells(lngZeile + 2, 1) = arrDaten(2, lngCounter)
lngZeile = lngZeile + 3
End If
End If
.Cells(lngZeile, 1) = arrDaten(3, lngCounter)
.Cells(lngZeile, 2) = arrDaten(4, lngCounter)
.Cells(lngZeile, 3) = arrDaten(5, lngCounter)
With .Range(.Cells(lngZeile, 1), .Cells(lngZeile, 3))
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
End With
lngZeile = lngZeile + 1
lngCounter = lngCounter + 1
Loop
End With
End Sub

    cu
    Chris
    Anzeige
    AW: Neustart
    18.09.2017 14:18:34
    Siggi
    Vielen dank für deine Mühe !!!
    Dieses neues Code liefert genau den Ergebnis, den ich brauche,
    nur leider liefert es nicht nur diesen Ergebiss, sondern auch die zwischentabellen ?
    kann man diese nicht in einem neuen Arbeitsblatt erstellen, und am ende diesen einfach löschen,
    damit in dem original nur die gewünschten Daten bleiben ?
    Ich habe hier noch mal im Bild markiert, was ich damit meine,
    Userbild
    das grau müsste weg, und das mit dem gelben Hintergrund, sind die gesuchten Daten,
    welche auch perfekt geordnet sind ;)
    das wäre dann die letzte Bitte noch
    Anzeige
    AW: Neustart
    18.09.2017 14:50:16
    ChrisL
    hi
    Du müsstest noch deine Beispieltabellen raus löschen oder in folgender Zeile ergänzen:
    If .Name "Übersicht" And .Name "Muster" And .Name "Auszug" Then
    cu
    Chris
    Danke schön !!
    18.09.2017 15:08:10
    Siggi
    Natürlich !
    tut mir leid,
    das war mein eigener Denkfehler !
    funktioniert super =)) !!
    vielen herzlichen Dank ChrisL !!!!
    AW: Danke schön !!
    18.09.2017 16:30:33
    ChrisL
    Hi
    Danke für die Rückmeldung. Das war ja mal eine Zangengeburt ;)
    Übrigens kannst du den Befehl...
    .Delete
    ... mal kurzfristig löschen resp. auskommentieren
    Dann siehst du die "Datenbank-ähnliche Struktur" im temporären Hilfsblatt. Ist mir klar, dass es nicht so schön dargestellt ist, aber mit solch strukturierten Lösungen ersparst du dir viel Kopfschmerz, wenn es um VBA geht. Zudem kannst du filtern und sortieren, was auch Vorteile hat.
    cu
    Chris
    AW: Danke schön !!
    18.09.2017 18:59:39
    Siggi
    danke für den Tip !

    313 Forumthreads zu ähnlichen Themen

    MSGBox wenn Zelleninhalt geleert wurde?!
    Tom

    Hallo!
    Ist es denn eigentlich möglich zu überprüfen ob eine Zelle gerade geleert wurde?
    Hintergrund ist, dass ich gern sicherstellen möchte, dass der User wirklich den Zelleninhalt löschen wollte.
    Ich würde gern eine Mitteilung erscheinen lassen wenn eine Zelle vom Inhalt her gelösc...
    26.08.2008 15:07:01
    Thread-ID: 1004826
    6 Beiträge
    Anzeige
    Wenn Zelle leer, dann Grafik löschen
    TomTom

    Hi,
    ich möchte auf meinem Sheet abprüfen, ob die Zelle A41 und B41 leer sind, und wenn ja, soll eine Grafik (.bmp / wurde eingefügt mit Kopieren und einfügen und heisst im Namensfeld "Bild 01")
    gelöscht oder unsichtbar werden.
    Wie mache ich dies ?
    Danke mal
    Gruss
    Tom<...
    22.09.2008 08:28:10
    Thread-ID: 1011373
    3 Beiträge
    Makro unterbrechen wenn bestimmte Zelle leer
    WalterK

    Guten Morgen,
    wer kann mir beim folgenden Code eine kleine Änderung durchführen:
    1.) das Makro sollte abgebrochen werden, wenn im Blatt "Daten" die Zelle "AB12" leer ist und
    2.) es sollte eine MsgBox mit dem Hinweis kommen, dass die Eingabe bei "AB12" fehlt und das sollte mit OK bes...
    03.10.2008 07:29:45
    Thread-ID: 1013985
    10 Beiträge
    Anzeige
    VBA leere Zelle finden und obere Inhalte einfügen
    Carmen

    Hallo Zusammen,
    leider habe ich so ganz wenig Ahnung von VBA, weiß aber auch nicht wie ich mir sonst normal mit
    Excel weiterhelfen könnte da es zuviele Daten sind.
    Hab folgendes Problem, ich möchte gerne dass alle leeren Zellen in den Spalten B-D mit dem Inhalt der Zellen eine Zeile...
    08.12.2008 17:08:41
    Thread-ID: 1031133
    5 Beiträge
    Kopieren von Nichtleeren Zellen per Formel
    Nichtleeren

    Moin,
    auf der Arbeit soll ich eine Tabelle anpassen:
    In Tabellenblatt1 ist eine Matrix M6:P109, in einigen Zeilen (Artikelnummern in loser Reihenfolge) stehen Werte, (die Artikel, die im Bürobestand fehlen) in den meisten nicht.
    Die Zeilen, in denen Werte stehen, sollen nun in Tabel...
    10.01.2009 20:43:46
    Thread-ID: 1038525
    4 Beiträge
    Kurze , dumme Frage: Prüfen, ob Zelle leer
    Dieter

    Hi,
    wie kann ich denn prüfen , ob die Zelle B230 im Tabellenblatt "Umsatz" leer ist ?
    (Wichtig, es ist nicht das Aktive Tabellenblatt)
    Danke Dieter
    29.01.2009 13:21:56
    Thread-ID: 1044976
    8 Beiträge
    Zählenwenns... Leere Zelle
    UweD

    Hallo
    Ich habe 2 Tabellen, wo (fast) täglich 1. Produktionsrückstände und 2. Fehler aufgelistet sind.
    Es kommt vor, daß eine Tabelle mal an einem Tag nicht abgefragt und gefüllt wird.
    In der Zusammenfassung wird dieser Tag dann mit 0 gewertet. Wie stelle ich es an, daß an diesem Tag...
    13.02.2009 10:55:00
    Thread-ID: 1050400
    5 Beiträge
    Wenn Dann mit Werten zwischen 2 Zellen
    Thomas

    Hallo,
    montagsgemäß steh ich gerade auf dem Schlauch und benötoge Hilfe für folgendes Problem:
    ich habe mind. 10 Werte in % von 50% bis 110%
    In den Zellen A1 bis A10 steht ein Text, dahinter also in B1 bis B10 die Prozentwerte.
    Dann steht in C1 ein Objektspezifischer Wert/ein E...
    23.02.2009 11:55:52
    Thread-ID: 1053025
    3 Beiträge
    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige
    Archiv - Verwandte Themen
    Forumthread
    Beiträge
    5
    6
    2
    9
    2
    4
    3
    7
    4
    2
    3
    7
    1
    4
    3
    23
    23
    1
    6
    9
    4
    4
    9
    4
    4