VBA Excel Zellen ohne Wert nich auswählen

Anonym

Hallo werte Gemeinschaft

Mein Problem:

Ich habe Tabellen in welcher in einer Spalte Werte in verschiedenen Zeilen stehen können.

Zelle mit Inhalt sollen gefunden werden um die benötigten Werte zu übernehmen und dann das Blatt zu speichern.

Ich benötige einen Sub welcher mir nur Zellen mit Inhalt sucht.

Meine Variante das mit Farbe zu bewerkstelligen funktioniert in soweit eigentlich, bis auf das auch Zellen ohne Inhalt aber der gesuchten Farbe mit übernommen werden.

Ich brauche aber nur die welche auch einen Inhalt haben.

Hier mein Sub:

Sub LN_KV1()

Dim n%

Dim Zeilenzahl As Long ', LRow As Long

Application.ScreenUpdating = False

With Sheets(1)

'Zeilenzahl Blatt1

LRow = .Cells(.Rows.Count, "D").End(xlUp).Row

For n = LRow To 2 Step -1

ActiveSheet.Unprotect

If .Cells(n, 52).Interior.Color = RGB(112, 48, 160) Then 'Zellenfarbe AZ Lila

If Application.CountIf(.Range("AZ:AZ"), .Cells(n, "AZ")) = 1 Then

Sheets("LNKV").Cells(6, 4).Resize(1, 1).Value = .Range("C" & n).Value 'Anrede

Sheets("LNKV").Cells(7, 4).Resize(1, 1).Value = .Range("D" & n).Value 'Name

Sheets("LNKV").Cells(7, 14).Resize(1, 1).Value = .Range("AZ" & n).Value 'KVNr

End If

LN_KV2_nichtAusf?hren 'Aufruf von LN_Soz2 Sub

End If

'Stop

End With

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

Gesperrte Frage. Diese Frage wurde aus der Microsoft-Support-Community migriert. Sie können darüber abstimmen, ob sie hilfreich ist, aber Sie können keine Kommentare oder Antworten hinzufügen oder der Frage folgen.

0 Kommentare

Antwort, die vom Frageautor angenommen wurde

Andreas Killer 144.1K Freiwilliger Moderator

Frank hat die Datei an uns beide per Mail geschickt. Ist sie bei dir im Spam-Ordner gelandet?

Hallo Claus,

die ist dann wohl schon unterwegs in irgendeinem Server hängen geblieben... tja, Dateien per Mail funktioniert heutzutage nicht mehr zuverlässig.

Naja, wenn Du Sie hast dann übernimm Du einfach den Part, ich klinke mich dann hier aus.

Andreas.

0 Kommentare

Antwort, die vom Frageautor angenommen wurde

Anonym

Hallo Andreas,

Frank hat die Datei an uns beide per Mail geschickt. Ist sie bei dir im Spam-Ordner gelandet?

Claus

0 Kommentare

Antwort, die vom Frageautor angenommen wurde

Andreas Killer 144.1K Freiwilliger Moderator

wenn du die Meldungen abschaltest, musst du sie am Ende auch wieder einschalten, sonst bleiben sie in allen Excel-Mappen abgeschaltet.

Nee, das stimmt nicht.

https://docs.microsoft.com/de-de/office/vba/api/excel.application.displayalerts

Wenn Sie diese Eigenschaft auf False festlegen, legt Excel diese Eigenschaft auf True fest, wenn der Code abgeschlossen ist, es sei denn, Sie führen einen prozessübergreifenden Code aus.

Aber kannst Du einen Link zu der Datei sehen? Ich seh nix.

Andreas.

0 Kommentare

Antwort, die vom Frageautor angenommen wurde

Anonym

Hallo Frank,

wenn du die Meldungen abschaltest, musst du sie am Ende auch wieder einschalten, sonst bleiben sie in allen Excel-Mappen abgeschaltet.

Du musst nicht den ganzen Bereich durchsuchen. Es reicht, wenn du die Zellen mit Inhalt durchläufst. Probiere mal:

Sub Test()

Dim Where As Range, rngC As Range

Dim LRow As Long

'Wo suchen?

With Sheets(1)

LRow = .Cells(.Rows.Count, "D").End(xlUp).Row

Set Where = .Range("AZ2:AZ" & LRow).SpecialCells(xlCellTypeConstants)

End With

'Keine Fehlermeldung falls Dateien überschrieben werden

Application.DisplayAlerts = False

'Suche in allen Zellen

For Each rngC In Where

'Daten übertragen

With Sheets("LNKV")

'Anrede

.Range("C4") = rngC.Offset(, -49)

'Name

.Range("C5") = rngC.Offset(, -48)

'KVNr

.Range("M5") = rngC

'Fertig

' Exit Sub

'Blatt kopieren und speichern

.Copy

With ActiveWorkbook

.SaveAs ThisWorkbook.Path & "" & rngC.Value

.Close

End With

Application.DisplayAlerts = True

End Sub

Claus

0 Kommentare

Antwort, die vom Frageautor angenommen wurde

Andreas Killer 144.1K Freiwilliger Moderator

Ja, soll nicht das Problem sein, aber wenn ich mir die Zielzellen in LNKV anschaue, (D6, D7, N7) dann vermute ich es soll nur ein Wert / Datensatz übertragen werden?

In dem Fall können wir die Schleife beenden sobald der erste Wert übertragen wurde.

Wenn das Blatt je Datensatz als separate Datei gespeichert werden soll, dann entferne das "Exit Sub" in dem Code unten.

Andreas.

Sub Test()
  Dim Where As Range, R As Range
  
  'Wo suchen?
  With Sheets(1)
    Set Where = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
  End With
  
  'Keine Fehlermeldung falls Dateien überschrieben werden
  Application.DisplayAlerts = False
  
  'Suche in allen Zellen
  For Each R In Where
    'Wenn wirklich ein Wert drin ist
    If Trim$(R.Value) <> "" Then
      'Daten übertragen
      With Sheets("LNKV")
        'Anrede
        .Range("D6") = R.Offset(, -1)
        'Name
        .Range("D7") = R
        'KVNr
        .Range("N7") = R.Offset(, 48)
        'Fertig
        Exit Sub
        'Blatt kopieren und speichern
        .Copy
        With ActiveWorkbook
          .SaveAs ThisWorkbook.Path & "\" & R.Value
          .Close
        End With
      End With
    End If
  Next
End Sub

0 Kommentare

Antwort, die vom Frageautor angenommen wurde

Anonym

Hallo,

ich hoffe, ich habe dich richtig verstanden. Probiere mal:

Sub Uebertrag()

Dim LRow As Long

Dim myRng As Range

With Sheets(1)

LRow = .Cells(.Rows.Count, "D").End(xlUp).Row

Set myRng = .Range("C1:C" & LRow).SpecialCells(xlCellTypeConstants)

myRng.Copy Sheets("LNKV").Range("D6")

myRng.Offset(, 1).Copy Sheets("LNKV").Range("E6")

myRng.Offset(, 49).Copy Sheets("LNKV").Range("N6")

End With

End Sub

Claus

0 Kommentare

9 zusätzliche Antworten

Anonym

2019-07-14T11:50:10+00:00

Hallo und Danke - aber funktioniert nicht weil ich mich blöd ausgedrückt habe.

Meine Mappe hat ein Arbeitsblatt Kunden. Von diesem Arbeitsblatt möchte ich die Anrede "Cx" den Namen "Dx" und eine Nummer "AZx"

auf ein weiteres Arbeitsblatt LNKV --- so in AZx ein Wert steht -- übernehmen.

Da sich das Blatt noch in Entwicklung befindet haben sich die Zellenbezüge geändert.

Der Wert aus "Cx" Kunden soll nach "C4" LNKV

   "Dx" "C5"

"AZx"    "M5" LNKV.

Ist in AZx kein Wert soll zu nächsten DS gegangen werden.

Ich hatte es mit der erweiterten Variante versucht, aber sobald kein Wert steht in AZx wird trotzdem ein DS geschrieben.

Option Explicit

Sub LN_KV1()

Dim n%

Dim Zeilenzahl As Long, LRow As Long

Application.ScreenUpdating = False

Cells(4, 13) = ""

With Sheets(1)

   'Zeilenzahl Blatt1

   LRow = .Cells(.Rows.Count, "D").End(xlUp).Row

   For n = LRow To 2 Step -1

ActiveSheet.Unprotect

     If .Cells(n, 52).Interior.Color = RGB(112, 48, 160) Then 'Zellenfarbe AZ Lila

      If .Cells(n, 52).Value = "" Then GoTo weiter

     If Application.CountIf(.Range("AZ:AZ"), .Cells(n, "AZ")) = 1 Then

             Sheets("LNKV").Cells(4, 3).Resize(1, 1).Value = .Range("C" & n).Value    'Anrede

             Sheets("LNKV").Cells(5, 3).Resize(1, 1).Value = .Range("D" & n).Value    'Name

             Sheets("LNKV").Cells(5, 13).Resize(1, 1).Value = .Range("AZ" & n).Value   'KVNr

        End If

        LN_KV2_nichtAusf?hren 'Aufruf von LN_KV2 Sub

        End If

       'Stop

weiter:

        Next

        End With

         ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

        End Sub

Das ist der Sub zu speichern des Tabellenblatts in eine Datei:

Option Explicit

Sub LN_KV2_nichtAusf?hren()

Dim Path As String, FName As String

Dim Monat As Variant

Dim Name As Variant

Monat = Cells(1, 3)

Name = Cells(5, 3)

'Pfad generieren

Path = "P:\001_Dokumente\1_LNKV" & Range("C1") & ""

'Erzeugen

If Not FolderCreate(Path) Then

    MsgBox Path, vbCritical, "Kann Pfad nicht erzeugen:"

    Exit Sub

End If

'Dateiname generieren

FName = Format(Now, "dd.mm.yyyy_hh.mm.ss__") & Monat & "_" & Name & "_LNKV_" & ".PDF"

'Exportieren

ActiveSheet.ExportAsFixedFormat xlTypePDF, Path & FName

'Monat = ""

'Name = ""

Application.Wait Now + TimeSerial(0, 0, 2) 'wartet 4 Sekunden

End Sub

Private Function FolderCreate(ByVal Path As String) As Boolean

'Creates a complete sub directory structure

Dim Temp, i As Integer

On Error GoTo ExitPoint

If Dir(Path, vbDirectory) = "" Then

    If Right$(Path, 1) = "" Then Path = Left$(Path, Len(Path) - 1)

    If Left$(Path, 2) = "\" Then

      i = InStr(3, Path, "")

      Temp = Split(Mid$(Path, i + 1), "")

      Temp(0) = Left$(Path, i) & Temp(0)

    Else

      Temp = Split(Path, "")

    End If

    Path = ""

    For i = 0 To UBound(Temp)

      Path = Path & Temp(i) & ""

      If Dir(Path, vbDirectory) = "" Then MkDir Path

    Next

End If

FolderCreate = True

ExitPoint:

End Function
War diese Antwort hilfreich?

0 Kommentare Keine Kommentare

Freigeben über

VBA Excel Zellen ohne Wert nich auswählen

9 zusätzliche Antworten