@ Sepp: Änderung Deines Makros

Hallo Sepp,
bei dem Beitrag hast Du mir netterweise geholfen.
https://www.herber.de/forum/archiv/1208to1212/t1211643.htm
Die Datei nutze ich derzeit:

Die Datei https://www.herber.de/bbs/user/75978.xls wurde aus Datenschutzgründen gelöscht

Nun habe ich drei Bitten.
Bitte 1
Kannst Du vor Spalte D ein neue Spalte einfügen, in der die Größe der Mail / Datei eingelesen wird.
Bitte 2
Kannst Du in die rote Spalte (verschiebt sich dann von F nach G) noch die Möglichkeit einbauen, dass ich mit dem Befehl "verschieben" die Mail-Dateien in einen anderen Ordner verschieben kann? Zielordner ist der dann immer gleiche. Eingabe des Zielordners wäre gut in Z1.
Bitte 3
In dem Mailnamen (siehe Spalte A) steht ARCHIVIERT. Mit welchem COde kann ich in einer beliebigen Spalte diese Kennung auslesen?
Kannst Du mir helfen? Ich hoffe, Du hast auch Lust.
Vielen lieben Dank!
Liebe Güße
Claudia

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Claudia,
ersetze den Code von "delMails" durch folgenden, wenn eine Datei bereits vorhanden ist, wird bei der Neuen der Dateiname mit einer Nummer ergänzt (Datei(1).msg, Datei(2).msg, usw.).

Sub delMails()
  Dim lngRow As Long, strLink As String, strFile As String
  Dim strPath As String, strName As String, strExt As String
  Dim lngIndex As Long, lngPos As Long
  Dim rng As Range
  
  With ActiveSheet
    strPath = .Range("Z1")
    strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
    
    For lngRow = 2 To Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
      If LCase(.Cells(lngRow, 7)) = "löschen" Then
        If .Cells(lngRow, 1).Hyperlinks.Count > 0 Then
          strLink = .Cells(lngRow, 1).Hyperlinks(1).Address
          If Dir(strLink, vbNormal) <> "" Then
            If rng Is Nothing Then
              Set rng = .Rows(lngRow)
            Else
              Set rng = Union(rng, .Rows(lngRow))
            End If
            Kill strLink
          End If
        End If
      ElseIf LCase(.Cells(lngRow, 7)) = "verschieben" Then
        strLink = .Cells(lngRow, 1).Hyperlinks(1).Address
        If Dir(strLink, vbNormal) <> "" Then
          strFile = Mid(strLink, InStrRev(strLink, "\") + 1)
          If Dir(strPath & strFile, vbNormal) <> "" Then
            lngPos = InStrRev(strFile, ".")
            strName = Left(strFile, lngPos - 1)
            strExt = Mid(strFile, lngPos)
            Do
              lngIndex = lngIndex + 1
              strFile = strName & "(" & CStr(lngIndex) & ")" & strExt
            Loop While Dir(strPath & strFile, vbNormal) <> ""
          End If
          Name strLink As strPath & strFile
        End If
      End If
    Next
    If Not rng Is Nothing Then rng.Delete
  End With
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread