Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1076to1080
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
Inhaltsverzeichnis

@ Sepp: Noch mal Hilfe!

@ Sepp: Noch mal Hilfe!
20.05.2009 16:35:47
Claudia
Hallo Sepp,
Du hattest mir unter diesem Link super geholfen.
https://www.herber.de/forum/archiv/1072to1076/t1075675.htm#1075720
Eine Frage hätte ich noch: Wäre es ohne großen Aufwand auch machbar, nach Farben zu suchen und bei "Fund" die Zeile zu kopieren?
ICh nutze derzeit folgndes Makro::

Sub blau_kopieren_und_löschen()
Application.StatusBar = "blau_kopieren_und_löschen"
Application.ScreenUpdating = False
Dim lZeile As Long, i As Long, j As Long
lZeile = Cells(Rows.Count, 1).SpecialCells(xlLastCell).Row
For i = lZeile To 1 Step -1 ' Zeilen
For j = 1 To 50        ' spalte A bis AJ
Select Case Cells(i, j).Interior.ColorIndex
Case Is = 41 'blau
'Case Is = 3, 6, 41, 43 'rot, gelb, blau und grün
Rows(i).Copy Destination:=Sheets("KV102-Hinweise").Cells(Sheets("KV102- _
Hinweise").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
Rows(i).Delete
Exit For
End Select
Next j
Next i
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Das Makro ist fertig!"
End Sub


Es ist halt sehr begrenzt, weil man im Editor die Änderungen vornehmen muss. D.h. man kann nicht jeden dran lassen und s gibt tatsächlich noch Mitarbeiter, die weniger Ahnung von Excel VBA haben als ich.
Muss ja auch nicht in der gleichen Userform sein. Gut wäre auf alle Fälle, wenn man die Spalten eintragen könnte, die durchsucht werden sollen. Derzeit habe ich 1 bis 50 dastehen. Aber in der Regel sind es natürlich weniger Spalten, die belegt sind.
?
VG
Claudia
PS: Sage danke, auch für den Fall, dass Du Dich nicht drangeben willst. Aber fragen kann ich ja mal. :-)

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: @ Sepp: Noch mal Hilfe!
20.05.2009 20:16:33
Josef
Hallo Claudia,
auf die Schnelle und ungetestet.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub blau_kopieren_und_löschen()
  Dim lngRow As Long, lngLast As Long, lngCol As Long
  Dim lngFirstCol As Long, lngLastCol As Long
  Dim rng As Range
  
  Do
    lngFirstCol = Application.InputBox("Bitte die erste zu durchsuchende Spalte eingeben:", "Startspalte", ActiveCell.Column, Type:=1)
    If lngFirstCol = 0 Then Exit Sub
    If lngFirstCol <= Columns.Count Then
      Exit Do
    Else
      MsgBox "Die Startspalte muss einen Wert zwischen 1 und " & CStr(Columns.Count) & " aufweisen!", vbExclamation, "Hinweis"
    End If
  Loop
  
  Do
    lngLastCol = Application.InputBox("Bitte die letzte zu durchsuchende Spalte eingeben:", "Endspalte", CStr(lngFirstCol + 1), Type:=1)
    If lngLastCol = 0 Then Exit Sub
    If lngLastCol >= lngFirstCol And lngLastCol <= Columns.Count Then
      Exit Do
    Else
      MsgBox "Die Startspalte muss einen Wert zwischen " & CStr(lngFirstCol) & " und " & CStr(Columns.Count) & " aufweisen!", vbExclamation, "Hinweis"
    End If
  Loop
  
  Application.StatusBar = "blau_kopieren_und_löschen"
  
  lngLast = Cells(Rows.Count, 1).SpecialCells(xlLastCell).Row
  
  For lngRow = 1 To lngLast
    For lngCol = lngFirstCol To lngLastCol
      Select Case Cells(lngRow, lngCol).Interior.ColorIndex
        Case Is = 41 'blau
          If rng Is Nothing Then
            Set rng = Rows(lngRow)
          Else
            Set rng = Union(rng, Rows(lngRow))
          End If
          Exit For
          'Case Is = 3, 6, 41, 43 'rot, gelb, blau und grün
        Case Else
      End Select
    Next
  Next
  
  If Not rng Is Nothing Then
    rng.Copy = Sheets("KV102-Hinweise").Cells(Sheets("KV102-Hinweise ").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
    rng.Delete
  End If
  
  Application.StatusBar = False
  MsgBox "Das Makro ist fertig!"
End Sub

Gruß Sepp

Anzeige
AW: @ Sepp: Noch mal Hilfe!
20.05.2009 20:32:12
Claudia
Hallo Sepp,
das Makro bleibt in der Zeile
" rng.Copy = Sheets("KV102-Hinweise").Cells(Sheets("KV102-Hinweise ").Cells(Rows.Count, 1).End
(xlUp).Row + 1, 1)"
hängen.
Andere Frage: Wäre ein Aufbau analog der tollen UserForm möglich (so unter dem Motto - es wird
kein Suchbegriff gesucht, sondern eine Farbe)? Oder sogar in der gleichen Userform?
Oder ist das ein Riesenaufwand? Wenn letzteres, würdest Du sowas gegen Geld programmieren?
Ich brauche das schon öfters auf der Arbeit und daher wäre das eine große Erleichterung die
Einstellungen in der Userform zu machen und nicht immer im Editor.
Liebe Grüße
Claudia
Anzeige
AW: @ Sepp: Noch mal Hilfe!
20.05.2009 20:50:18
Josef
Hallo Claudia,
für Geld mach ich "fast" alles ;-))
ersetze diesen Teil
If Not rng Is Nothing Then
  With Sheets("KV102-Hinweise")
    rng.Copy .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
    rng.Delete
  End With
End If

In das UF kann man das schon integrieren, wenn ich später noch Lust habe, dann Bastle ich dir was. (ohne Bezahlung)
Gruß Sepp

Anzeige
AW: @ Sepp: Noch mal Hilfe!
20.05.2009 21:18:58
Claudia
Na, dann hoffe ich mal, dass Du noch Lust hast.
Die Änderung klappt auf alle Fälle. :-)
AW: @ Sepp: Noch mal Hilfe!
20.05.2009 21:55:22
Claudia
Hallo Sepp,
klappt noch nicht. Es wird nix kopiert.
Zusätzlich: Wenn ich eine bestehende Tabelle auswähle, gibt es beim Makrostart einen Fehlerhinweis.
Kannst Du bitte mal schauen. Könntest Du bitte im Feld "gefundene Daten" das Häckchen als Standard einfügen. Das ist der Regelfall. DAnn brauche ich da nur im Einzelfall drandenken.
Danke!
Anzeige
AW: @ Sepp: Noch mal Hilfe!
20.05.2009 22:17:11
Claudia
Hallo Sepp,
klappt herrvorragend. Toll finde ich vor allem, dass ich direkt mehrere Farben ansprechen kann.
Bin voll zufrieden. Vielen vielen Dank für Deine Hilfe, die Zeit und die Mühe!
Schönen Abend wünsche ich Dir!
Claudia
Doch noch eine Frage.
20.05.2009 23:10:24
Claudia
Hallo Sepp,
doch noch eine kleine Frage bzw. ein Problem.
Es werden nur farbige Zeilen kopiert, wenn etwas drin steht. Ist die farbige Zelle leer, passiert nichts.
Liege ich da richtig? Ansonsten klappt bei mir etwas anderes nicht.
Wenn ja, wäre das noch machbar, dass die Zeile auch dann kopiert wird, wenn sie nur farbig, aber leer ist.
Anzeige
AW: Doch noch eine Frage.
20.05.2009 23:21:41
Josef
Hallo Claudia,
ersetze die Zeile

lngLast = objWSSearch.Cells(Rows.Count, 1).End(xlUp).Row


durch


lngLast = objWSSearch.UsedRange.SpecialCells(xlLastCell).Row


Gruß Sepp

Juhu, jetzt bin ich glücklich. :-)
20.05.2009 23:24:23
Claudia
Danke schön!
Und jetzt hast Du Ruhe vor mir.

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige