Excel VBA gibt nicht die korrekte Kalenderwoche zurück?

Guten Morgen zusammen, ich habe eine Tabelle, in der Audits geplant werden. Von Spalte K bis Spalte BI sind die einzelnen Kalenderwochen eingetragen und bei den jeweiligen Produkten darunter steht immer eine 1 wenn ein Audit in der KW erfolgen soll. In Spalte I möchte ich mir jetzt durch Komma getrennt die KW anzeigen lassen, in der das Audit geplant ist. Mein VBA sieht folgendermaßen aus:

Function VerbindeKW(Bereich As Range) As String

Dim Zelle As Range

Dim Ergebnis As String

Dim KW As Integer

For Each Zelle In Bereich

If Zelle.Value = 1 Then

KW = Zelle.Column - 10 ' K = Spalte 11 = KW1

Ergebnis = Ergebnis & "KW" & KW & ", "

End If

Next Zelle

If Ergebnis <> "" Then

VerbindeKW = Left(Ergebnis, Len(Ergebnis) - 2)

Else

VerbindeKW = ""

End If

End Function

Jetzt gibt die Funktion mir die allererste Kalenderwoche korrekt zurück (aber auch nur in der ersten Zelle) und danach ist es immer eine KW zu wenig. Ich habe mich fest auf Spalte K festgelegt, weil dort KW1 hinterlegt ist. Kann mir jmd da weiterhelfen? Herzliche Grüße Annette

2 Antworten

daCypher

04.04.2025, 09:37

Hmm, ich kann das Problem nicht nachvollziehen. Bei mir rechnet deine Funktion richtig. Das einzige, was mir aufgefallen ist, ist dass von K bis BI nur 51 Spalten sind und ein Jahr in der Regel 52 KWs hat. Vielleicht kannst du da mal schauen, ob du links oder rechts eine Spalte zu wenig erwischt hast.

Ich würde Berechnungen, die nicht zwingend in VBA erfolgen müssen, aber immer als Excel-Formeln hinterlegen. Das hat (falls das hier die einzige VBA-Funktion ist) den Vorteil, dass du die Excel ohne Makros speichern kannst und dadurch z.B. keine Probleme kriegst, wenn du die Datei per Mail verschicken willst.

Dein Beispiel als Excel-Formel würde so aussehen (für Zeile 2):

=TEXTVERKETTEN(", "; WAHR; FILTER("KW " & SPALTE(K2:BI2)-10;K2:BI2=1))

Annette0806

Beitragsersteller

04.04.2025, 09:57

Das war auch tatsächlich meine erste Idee, dies über eine Funktion zu regeln. Bei deiner Funktion sagt Excel mir, dass die Funktion FILTEr ungültig sei. Ich habe Excel 2016. Kannst du mir da weiterhelfen? Vielen Dank aber schonmal. Herzliche Grüße Annette

daCypher

04.04.2025, 10:13

@Annette0806

Ja, die Funktion FILTER gibt es glaub ich seit Excel 2019. Da sind auch die ganz praktischen dynamischen Arrays hinzugekommen. Ich hab leider kein Excel 2016 da, um mit alternativen Formeln zu experimentieren. Falls es die Funktion TEXTVERKETTEN in Excel 2016 gibt, müsste es hiermit funktionieren:

=TEXTVERKETTEN(", ";WAHR; WENN(K2=1; "KW 1"; ""); WENN(L2=1; "KW 2"; ""); WENN(M2=1; "KW 3"; ""); WENN(N2=1; "KW 4"; ""); WENN(O2=1; "KW 5"; ""); WENN(P2=1; "KW 6"; ""); WENN(Q2=1; "KW 7"; ""); WENN(R2=1; "KW 8"; ""); WENN(S2=1; "KW 9"; ""); WENN(T2=1; "KW 10"; ""); WENN(U2=1; "KW 11"; ""); WENN(V2=1; "KW 12"; ""); WENN(W2=1; "KW 13"; ""); WENN(X2=1; "KW 14"; ""); WENN(Y2=1; "KW 15"; ""); WENN(Z2=1; "KW 16"; ""); WENN(AA2=1; "KW 17"; ""); WENN(AB2=1; "KW 18"; ""); WENN(AC2=1; "KW 19"; ""); WENN(AD2=1; "KW 20"; ""); WENN(AE2=1; "KW 21"; ""); WENN(AF2=1; "KW 22"; ""); WENN(AG2=1; "KW 23"; ""); WENN(AH2=1; "KW 24"; ""); WENN(AI2=1; "KW 25"; ""); WENN(AJ2=1; "KW 26"; ""); WENN(AK2=1; "KW 27"; ""); WENN(AL2=1; "KW 28"; ""); WENN(AM2=1; "KW 29"; ""); WENN(AN2=1; "KW 30"; ""); WENN(AO2=1; "KW 31"; ""); WENN(AP2=1; "KW 32"; ""); WENN(AQ2=1; "KW 33"; ""); WENN(AR2=1; "KW 34"; ""); WENN(AS2=1; "KW 35"; ""); WENN(AT2=1; "KW 36"; ""); WENN(AU2=1; "KW 37"; ""); WENN(AV2=1; "KW 38"; ""); WENN(AW2=1; "KW 39"; ""); WENN(AX2=1; "KW 40"; ""); WENN(AY2=1; "KW 41"; ""); WENN(AZ2=1; "KW 42"; ""); WENN(BA2=1; "KW 43"; ""); WENN(BB2=1; "KW 44"; ""); WENN(BC2=1; "KW 45"; ""); WENN(BD2=1; "KW 46"; ""); WENN(BE2=1; "KW 47"; ""); WENN(BF2=1; "KW 48"; ""); WENN(BG2=1; "KW 49"; ""); WENN(BH2=1; "KW 50"; ""); WENN(BI2=1; "KW 51"; ""))

Annette0806

Beitragsersteller

04.04.2025, 14:02

@daCypher

Hallo daCypher, es war tatächlich ein Fehler in den KWs, du hattest festgestellt, dass es nur 51 Zellen sind. Tja, da hatte die Kollegin glatt KW14 vergessen. Jetzt funktioniert es aber. Dankeschön

daCypher

04.04.2025, 14:06

@Annette0806

Ah, super. Ja, manchmal drückt man versehentlich eine Taste und die Spalte wird gelöscht. Gut, dass es jetzt geht 👍

Slevi89

04.04.2025, 09:37

Ein paar mehr Informationen wären schön. Wie und wo hast du deinen "Bereich" definiert? Typischerweise wird dieser mit einem Set Kommando festgelegt, der hier vollkommen fehlt. Das heißt, du wirst ihn irgendwo anders im Makro definiert haben. So ist es schwierig deinen Code zu debuggen, da ich das Problem nicht nachstellen kann.

Annette0806

Beitragsersteller

04.04.2025, 14:04

Wenn ich dich richtig verstehe, möchtest du wissen, wie ich definiere, duch welche zellen Excel gehen soll oder? das mache ich über die Funktion =VerbindeKW(B6:BI6) Aber da fehlt eine Zelle (s.o.) und daher gibt es den Fehler. Danke für den Hinweis, beim nächsten Mal werde ich noch genauer schreiben wo der Fehler liegt.

daCypher

04.04.2025, 10:04

Du kannst die Funktion, so wie sie ist, in einer Formel auf einem Tabellenblatt benutzen. "Set" brauchst du nur, wenn du die Funktion in einer anderen VBA-Funktion benutzen willst

Z.B.

=VerbindeKW(K2:BI2)

Ähnliche Beiträge

VBA Wenn eine Zelle mehrerer Spalten leer dann msgbox?

Hallo zusammen,

ich habe vor in mehreren Spalten zu kontrollieren, ob sich eine leere Zelle befindet. Wenn ja soll eine Msgbox angezeigt werdne und der Sub soll beendet werden. Wenn nicht soll er fortfahren. Allerdings kommt es bei mir zu einer Fehlermeldung "Typen unverträglich". Wo hat sich der Fehler eingeschlichen? End If befindet sich weiter unten.

Sub SendMeetingRequest_2()

Dim Bereich As Range

Set Bereich = Range("F2:H41", "B2:B41") 'Zellbereich

With Application.WorksheetFunction

Dim objOL As Object 'As Outlook.Application

Dim objAppt As Object 'As Outlook.AppointmentItem

'Const olAppointmentItem = 1

Const olMeeting = 1

Dim ReminderTime As Long

Dim lfdnr As Integer

lfdnr = 2

'Überprüfung erstellen falls Aufgaben leer sind

'lfdnr = 4

If Bereich.Value = "" Then

MsgBox "Bitte fehlende Daten eintragen"

Call Leere_zellen_hervorheben

Exit Sub

Else

Danke für eure Hilfe!

...zum Beitrag

VBA zu HTML Code umgewandelt - Zeilenumbrüche weg?

Hallo,

ich habe durch den unten beigefügten Code versucht eine E-Mail samt Signatur automatisch kommen zu lassen. Nun habe ich das Problem, dass die Absätze in der Mail weg sind und alles in einer Zeile ist. Wie behebe ich das?

Private Sub CommandButton2_Click()

Dim objOutlook As Object

Dim objMail As Object

Dim S As String

Dim body As String

Dim htbody As String

Set objOutlook = CreateObject("Outlook.Application")

Set objMail = objOutlook.CreateItem(0)

If TextBox2.text = "" Or TextBox2.text = TextBox1.text Then

body = "Sehr geehrte Frau x," & vbCrLf & _

vbCrLf & _

"Folgende/r Mitarbeiter/in ist erkrankt:" & vbCrLf & _

vbCrLf & _

ComboBox1.text & vbCrLf & _

vbCrLf & _

"Zeitraum: " + TextBox1.text

Else

body = "Sehr geehrte Frau x," & vbCrLf & _

vbCrLf & _

"Folgender Mitarbeiter ist erkrankt:" & vbCrLf & _

vbCrLf & _

ComboBox1.text & vbCrLf & _

vbCrLf & _

"Zeitraum: " + TextBox1.text + " bis " + TextBox2.text

End If

htbody = fnConvert2HTML(htbody)

S = Environ("appdata") & "\Microsoft\Signatures\autoE-Mailsenden.htm"

If Dir(S, vbDirectory) <> vbNullString Then

S = S

S = CreateObject("Scripting.FileSystemObject").GetFile(S).OpenAsTextStream(1, -2).readall

With objMail

.To = "x.de"

.Subject = "Krankmeldung " + ComboBox1.text + " x"

htbody = body & " " & S

.htmlbody = "" & htbody & ""

.Display 'Erstellt die Email und öffnet diese. Der Versand erfolgt anschließend manuell vom User!

End With

Else

' With objMail

' .To = Empfänger

' .Subject = Betreff

' htbody = body '& " " & S

' .htmlbody = "" & htbody & ""

' .Display

' ' .Display 'Erstellt die Email und öffnet diese. Der Versand erfolgt anschließend manuell vom User!

' End With

End If

End Sub

Zudem noch folgende Funktion:

Function fnConvert2HTML(myText As String) As String

Dim bldTagOn, itlTagOn, ulnTagOn, colTagOn As Boolean

Dim i, chrCount, n As Integer

Dim chrCol, chrLastCol, htmlTxt As String

Dim myChar As String

bldTagOn = False

itlTagOn = False

ulnTagOn = False

colTagOn = False

chrCol = "NONE"

htmlTxt = "<html>"

chrCount = Len(myText)

End Function

Danke im voraus!!!

...zum Beitrag

Maximale Pfadlänge in Windows und VBA umgehen?

Hallo,

ich benutze folgenden Code in Excel VBA um mir Dateipfad und Dateiname eines Ordners und allen darin enthaltenen Unterordnern aufzulisten.
(Ihr könnt es testen, den Code einfach in ein Modul kopieren, "MainList" ausführen und einen Ordner eurer Wahl auswählen)

Ich habe jetzt das Problem, dass dieser Code alle Dateien überspringt, deren Pfadlänge über 255 Zeichen lang ist. Einige Dateien überschreiten nämlich die 255 Zeichen mit dem angehängten Dateinamen.
Sie liegen aber dennoch ab. Nur liest VBA diese nicht aus. Kann man da was dran machen?

Sub MainList()
'Updateby Extendoffice
Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
If Folder.Show <> -1 Then Exit Sub
xDir = Folder.SelectedItems(1)
Call ListFilesInFolder(xDir, True)
End Sub

Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean)
Dim xFileSystemObject As Object
Dim xFolder As Object
Dim xSubFolder As Object
Dim xFile As Object
Dim rowIndex As Long
Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFileSystemObject.GetFolder(xFolderName)
rowIndex = Application.ActiveSheet.Range("A65536").End(xlUp).Row + 1
For Each xFile In xFolder.Files
  Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Path
  Application.ActiveSheet.Cells(rowIndex, 2).Formula = xFile.Name
  rowIndex = rowIndex + 1
Next xFile
If xIsSubfolders Then
  For Each xSubFolder In xFolder.SubFolders
    ListFilesInFolder xSubFolder.Path, True
  Next xSubFolder
End If
Set xFile = Nothing
Set xFolder = Nothing
Set xFileSystemObject = Nothing
End Sub

Function GetFileOwner(ByVal xPath As String, ByVal xName As String)
Dim xFolder As Object
Dim xFolderItem As Object
Dim xShell As Object
xName = StrConv(xName, vbUnicode)
xPath = StrConv(xPath, vbUnicode)
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.Namespace(StrConv(xPath, vbFromUnicode))
If Not xFolder Is Nothing Then
  Set xFolderItem = xFolder.ParseName(StrConv(xName, vbFromUnicode))
End If
If Not xFolderItem Is Nothing Then
  GetFileOwner = xFolder.GetDetailsOf(xFolderItem, 8)
Else
  GetFileOwner = ""
End If
Set xShell = Nothing
Set xFolder = Nothing
Set xFolderItem = Nothing
End Function

...zum Beitrag

IF Funktion in excel auf mehrere Zellen anwenden?

Hallo,

Ich möchte wenn in einer Zelle etwas reingeschrieben wird das die darauffolgenden Felder zu Pflichtfelder werden. Dazu nutze ich aktuell folgende Formel.

Private Sub Workbook_BeforePrint(Cancel As Boolean)

Dim zeile As Long, OK As Boolean

OK = True

For zeile = 1 To Tabelle1.Cells.SpecialCells(xlCellTypeLastCell).Row

If Worksheets("Tabelle1").Cells(4, 2).Value <> "" Then

If Worksheets("Tabelle1").Cells(4, 3).Value = "" Then OK = False 'Spalte C

If Worksheets("Tabelle1").Cells(4, 4).Value = "" Then OK = False 'Spalte D

If Worksheets("Tabelle1").Cells(4, 5).Value = "" Then OK = False 'Spalte E

If Worksheets("Tabelle1").Cells(4, 6).Value = "" Then OK = False 'Spalte F

If Worksheets("Tabelle1").Cells(4, 8).Value = "" Then OK = False 'Spalte H

If Worksheets("Tabelle1").Cells(4, 9).Value = "" Then OK = False 'Spalte I

End If

If Not OK Then

MsgBox "Drucken nicht möglich - nicht alle Pflichtfelder ausgefüllt"

Cancel = True

End If

End Sub

Nun möchte ich das die obige Formel von B4- B25 durchgeführt wird. Also das wenn in in B8 z.B. etwas reingeschrieben wird das dann die Zellen in B8 geprüft werden das dort in den anderen Feldern auch was reingeschrieben worden ist.
Wie würde ich das ganze hinbekommen?

Danke im Voraus

...zum Beitrag

Excel Colorsum Ergebnis automatisch aktualisieren lassen?

Moin, ich habe in Excel über Visual Basics folgenden Code eingefügt:

Function ColorSum(ByRef Source As Range, ByVal Color As Integer, Optional ByVal ForeOrBack As Boolean = -1) As Double

Dim rng As Range, dblSum As Double

Application.Volatile

If Color < 0 Or Color > 56 Then Color = IIf(ForeOrBack, -4142, -4105)

For Each rng In Source

If IsNumeric(rng) Then

If ForeOrBack Then

If rng.Interior.ColorIndex = Color Then dblSum = dblSum + rng

Else

If rng.Font.ColorIndex = Color Then dblSum = dblSum + rng

End If

ColorSum = dblSum

End Function

Dies hat die Funktion, dass ich zahlen zusammen rechnen kann anhand der Farbe. Das Funktioniert auch alles so weit. Nur weiß ich nicht wie ich es hinkriege dass sich das Ergebnis automatisch aktualisiert nachdem ich die Farbe z.B. von rot auf grün umändere. Dann sollte eigentlich aus summe X eine summe heraus kommen die um 1 weniger ist. Dies sehe ich aber erst dann, nachdem ich in die Spalte gehe (wo die Formel ist) und die Entertaste drücke. Geht das auch ohne das ich es Manuell aktualisieren muss?

...zum Beitrag

Arbetismappe mit datum durchsuchen?

Hallo Zusammen,

ich habe eine Arbeitsmappe mit Tabellenblätter, wo sich die Namen variieren.

Da aber im jeden Tabellenblatt in Zelle A1 ein Datum Steht, will ich jedes Tabellenblatt dem Heutigen datum suchen, zellen aus dem blatt kopieren und in eine Andere arbeitsmappe einfügen, danach das gleiche noch einmal mit dem gestrigen datum.

Aktuell sieht mein Code so aus, aber der gibt mir nur die MsgBox, dass nichts gefunden worden ist.

  'Aktuelles Datum auswählen bei Start
Dim bolHabWasGefunden As Boolean
Dim wksTabelle As Worksheet
Dim rngSpalteA As Range
Dim rngZelleGefunden As Range
For Each wksTabelle In ThisWorkbook.Worksheets
 Set rngSpalteA = wksTabelle.Columns(1)
 Set rngZelleGefunden = rngSpalteA.Find(Date, LookIn:=xlValues)
 If Not rngZelleGefunden Is Nothing Then
  wksTabelle.Activate
  rngZelleGefunden.Select
  bolHabWasGefunden = True
  Exit For
 End If
Next
If bolHabWasGefunden = False Then
 MsgBox Date, , "Hab ich nicht gefunden:"
End If

Kennt da jemand einen ansatz bzw, eine lösung?

...zum Beitrag

Excelwerte in VBA Label übertragen. Wie mach ich das?

Der Inhalt, der in der Combobox ausgewählt wird, erscheint im Labelfeld. Und je nachdem, was jetzt im Label steht wird in die Excel Tabelle geschaut und die "Straße" ausgewählt und dann in ein anderes Labelfeld übertragen. Auf dem gleichem Userform.

Meine Frage ist jetzt: wie hole ich die Werte aus der ExcelTabbelle nach der Auswahl?

(Unten habe ich meinen gescheiterten Versuch aufgelistet)

Danke schon mal im voraus.

Private Sub comSuchen_Click()

Dim wksTab1 As Worksheet

Dim anmiet As Byte

Dim ausgabean As String

anmiet = comAnmietstation.ListIndex

Set wksTab1 = Sheets("Tabelle1")

If anmiet = 0 Then

ausgabean = Tabelle1.Range("D7").Value2

ElseIf anmiet = 1 Then

ausgabean = Tabelle1.Range("D8").Value2

ElseIf anmiet = 2 Then

ausgabean = Tabelle1.Range("D9").Value2

End If

lblAn.Caption = ausgabean

End Sub

...zum Beitrag

Werte abgleichen und ggf Fehlermeldung ausgeben, VBA?

Hallo zusammen,

ich möchte in meinem Excel Sheet einrichten, dass wenn der Nutzer einen Wert in Zelle A2 eingibt, welcher keinem der Werte in Spalte V entspricht eine Fehlermeldung ausgegeben wird. Bisher habe ich den Code unten.


Sub Worksheet_Change(ByVal Target As Excel.Range)



If Target.Address = "$A$2" And Cells(2, 1).Value <> Range("V:V").Select Then
MsgBox "Sie haben gerade Zelle A2 verändert!"
End If
End Sub

Das Problem ist, dass mein Code durchläuft als würde es die zweite If-Bedingung (unten) nicht geben

And Cells(2, 1).Value <> Range("V:V").Select

Kann mir jemand helfen das Problem zu fixen / eine Alternative vorschlagen?

...zum Beitrag

Excel: Variablen in Makros einfügen und in Datenbank pflegen/ändern?

Hallo liebe Community,

ich habe diverse Makros in meiner Excel Datei und ich würde gerne das ganze etwas "smarter" gestalten und eine Art Datenbank mit VBA erstellen, um viele Sachen in der Arbeitsmappe dadurch ändern/pflegen zu können. Externe Leute sollen und müssen dann nicht mehr in die VBA Oberfläche und mühsam das Makro suchen, um dort Pfade oder Zeilen zu ändern, falls sich was ändert.

Meine Frage:

Ist es möglich in ein Makro bei VBA eine Art Variable einzubauen bzw. Pfad, wo Excel z.B. in Tabelle1 in Spalte A1 den Wert/Namen findet?

Beispiel Makro:

Statt Daten123.xlsx soll dann ein Bezug hin, wo Excel in Tabelle1 in A1 den Namen Daten123.xlsx findet. Ist sowas möglich?

Dim sPfad As String
Dim wbQuelle As Workbook
Dim zelle As Range
Dim loletzte As Long

sPfad = "C:\Users\P\Desktop\Dateiordner\Unterordner\Daten123.xlsx"

If Dir(sPfad) <> "" Then

Set wbQuelle = Workbooks.Open(sPfad)

Call Test

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

wbQuelle.Worksheets(1).Range("A7:I" & loletzte).Copy ThisWorkbook.Worksheets(3).Range("B2")

wbQuelle.Close savechanges:=False

End If

...zum Beitrag

VBA Input-Eingabe in Zelle eintragen?

Guten Abend,

ich möchte gerne den Inhalt aus einer Inputbox in Zelle D28 schreiben, nur leider funktioniert es nicht.

Folgendes Makro: (sicherlich nicht schön geschrieben aber es bis auf die Zelle D28)

Sub erstellen()
   Dim NeuerTabellenName As String
   Dim TabellenName As Boolean
   Dim myInput As String
   Dim WsTabelle As Worksheet
   
   myInput = InputBox("Bitte geben Sie den Namen des neuen Monates an", "Monat anlegen")
   
   For Each WsTabelle In Worksheets
   If WsTabelle.Name = myInput Then
   TabellenName = True
   Exit For
   End If
   Next WsTabelle
   If TabellenName Then
   MsgBox ("Der Monat existiert bereits. Der Vorgang wurde abgebrochen. Bitte ueberpruefen Sie Ihre Eingabe.")
   Worksheets("Admin").Select
   Else
   NeuerTabellenName = myInput
   Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
   Sheets(Sheets.Count).Name = NeuerTabellenName
   Worksheets("Admin").Range(D28).Value = myInput
   Worksheets("Admin").Select
   End If
End Sub

Der Fehler muss ja hier liegen:

Worksheets("Admin").Range(D28).Value = myInput

Über eine Lösung wäre ich sehr dankbar.

Gruß

...zum Beitrag

VBA CODE Zellen nach bestimmten Textinhalt suchen und Zeile Färben?

Hallo, kann mir bitte jemanden mit dem Code behilflich sein?

Dieser Code sucht die Zellen in Spalte"A" nach bestimmten Textinhalt ab und bei Treffer löscht er die zughörige gesamte Zeile. Meine Frage: kann man diesen Code so ändern, dass anstatt die gefundene Zeile zu löschen nur mit einer Farbe z.B. Orange (44) färbt? Vielen Dank im Voraus.

Sub zeilenloeschen()
  Dim i As Long
  Dim letzteZeile As Long
  Dim suchBereich As Range
  Dim gefunden As Range
  Dim ersterTreffer As String
  Dim suchWert As String
  suchWert = "1" 'hier kommt dein Suchwert rein
  
  With ThisWorkbook.Sheets("Sheet4")
    letzteZeile = .Range("A" & Rows.Count).End(xlUp).Row
    Set suchBereich = .Range("A1:A" & letzteZeile)
    Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
    If Not gefunden Is Nothing Then
      ersterTreffer = gefunden.Address
      Do
        gefunden.Activate
        ActiveCell.EntireRow.Delete shift:=xlUp
        Set gefunden = suchBereich.Find(What:=suchWert, LookAt:=xlPart)
      Loop While Not gefunden Is Nothing
    End If
  End With
End Sub

...zum Beitrag

Excel VBA eine große Menge leere Zeilen löschen?

Hallo, ich lade eine menge Datensätze in eine Tabelle rein und dabei werden auch die leeren Zeilen zwischendurch mal reinkopiert. Diese möchte ich nun entfernen. Das gelingt mir mittlerweile auch. Das Problem ist, dass es zu lange dauert bei ca. 2800 leere Zeilen, da diese einzeln angeschaut werden und gelöscht. Mein bisheriger Code:

Function loescheLeerenBereichn()

Dim Zelle As Long
Dim LetzteZeile As Long
LetzteZeile = Sheets("Lieferung").UsedRange.SpecialCells(xlCellTypeLastCell).Row
For Zelle = LetzteZeile To 7 Step -1 ' In Range(Cells(7, 4), Cells(LetzteZeile, 4))
If Cells(Zelle, 3) = "" Or Cells(Zelle, 3) = "." Then
Rows(Zelle).EntireRow.Delete Shift:=xlUp 
End If
Next Zelle

End Function

Wie kann man das schneller programmieren?

...zum Beitrag

VBA: Split-Funktion mit einem Trennzeichen?

Hallo zusammen,

ich stehe vor einem Problem, woran ich schon seit Tagen arbeite und keine Lösung finde.

Meine Split-Funktion klappt soweit, die Daten werden eingefügt. Allerdings in der ersten der ersten Zeile von (D). Ich benötige die Daten aber ab Zeile (D20) und das bekomme ich nicht hin.

Hat bitte jemand einen Lösungsvorschlag, da ich nicht so fit mit VBA bin?

Dim MeinArray() As String
Dim MeineZeichenkette As String
Dim I As Variant
Dim N As Integer
Dim WB As Worksheet
Set WB = ThisWorkbook.Sheets("Abrechnung")

Dim WBlerf As Worksheet
Set WBlerf = ThisWorkbook.Sheets("Tabelle1")
Ziel = WBlerf.Range("D20")

'Beispielzeichenkette mit Semikolon als Trennzeichen
MeineZeichenkette = WB.Range("Aufmaß_srvpos")

'Die Funktion Split verwenden, um die Bestandteile der Zeichenkette aufzuteilen
MeinArray = Split(MeineZeichenkette, ";")

'Das Arbeitsblatt leeren
'ActiveSheet.UsedRange.Clear

'Durch das Array iterieren
For N = LBound(MeinArray) + 0 To UBound(MeinArray)
  'Jede E-Mail-Adresse in die erste Spalte des Arbeitsblatts einfügen
  WBlerf.Range("D" & N + 1).Value = MeinArray(N)
Next N

Lieben Dank und VG

Stefan

...zum Beitrag

VBA Datum (dd.mm.yy) aus Zelle umdrehen (yymmdd) und als Name speichern?

Hallo Zusammen

Ich bin ganz neu im VBA und bin etwas am Herumprobieren. Einen Teil habe ich geschafft, aber an einem Punkt hänge ich.

Ich will, dass ein Makro läuft, welches die Datei automatisch unter dem Namen "Kundennummer_Servicedatum" abspeichert. Die Kundennummer und das Servicedatum sind beide im Dokument unter separaten Zellen hinterlegt, die Formel sieht jetzt so aus:

Sub Speichern_unter()

Dim SaveName As String

Dim Datum As Date

SaveName = ActiveSheet.Range("BQ11").Text

Datum = ActiveSheet.Range("BM17")

ActiveWorkbook.SaveAs Filename:="D:\ABC\Service\" & SaveName & "_" & Datum & ".xls"

End Sub

Soweit funktioniert alles, das Dokument heisst z.b. "149_31.10.23"

Das Datum ist als dd.mm.yy in der Zelle, zum Abspeichern brauche ich aber folgendes Format: yymmdd. Ziel ist also der Name "149_231031"

Kann mit jemand helfen, wie ich das Datum umgedreht bekomme? Danke im Voraus :)

...zum Beitrag

Was möchtest Du wissen?

Deine Frage stellen