seltsames remove duplicates Problem
24.11.2021 10:53:21
Daniel
Dank der tollen Hilfe hier ist mein Arbeitsprojekt ziemlich weit fortgeschritten. Nunmehr stellt sich eine Remove.Duplicate Prozedur quer, sobald die Arbeitsmappe freigegeben wird (was sie verpflichtend muss). Was wird gemacht? Es werden gefilterte Namen (visible via specialcell) ausgelesen, in eine Hilfsspalte eines anderen Arbeitsblattes ohne Filter kopiert und dort auf Dopplungen geprüft. Anschließend wird ein passender Email Adress-Verteiler erzeugt, die Hilfsspalte geleert und eine Email mit den Filter-Daten im Html-Body aufgerufen.
Die VBA-Lösung läuft im Single-Mode perfekt - aber nicht im Freigabe-Modus, was sich mir nicht erschließt. Es sind keine Zellen, Arbeitsblätter oder sonst irgendein Bereich ausgeblendet oder gesperrt. Copy-Paste-Delete und Filter kann man doch auch in freigegebenen Mappen durchführen ... anbei die Datei https://www.herber.de/bbs/user/149352.xlsm und der fragliche Code:
Bin für jede Hilfe dankbar.
Sub CommandButton1_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim LastRow As Long
Dim i As Long, j As Long
Dim emailList As String
Dim foundEmails As Long
Set rng = Nothing
On Error Resume Next
With Application
.EnableEvents = False
.ScreenUpdating = False
.Visible = True
End With
'nur sichtbare Zellen der Filter
With Worksheets("Testbedarf BvB")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = .Range("A5:G" & LastRow).SpecialCells(xlCellTypeVisible)
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
' Kopiert die Namen in temporäre Spalte "Z" in "Bibliothek" und entfernt die Dopplungen
.Range("G5:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy
End With
With Worksheets("Bibliothek")
.Range("Z1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
.Range("$Z1:Z" & LastRow).RemoveDuplicates Columns:=1, Header:=xlNo
'erzeugt Email Liste insofern in Spalte "M" Bibliothek gematched
emailList = ""
foundEmails = 0
LastRow = .Cells(.Rows.Count, "Z").End(xlUp).Row
For i = 1 To LastRow
Debug.Print i, .Range("Z" & i)
For j = 4 To 1000
If .Range("K" & j).Value = "" Then Exit For
If .Range("K" & j).Value = .Range("Z" & i).Value Then
emailList = emailList & .Range("M" & j).Value & ";"
foundEmails = foundEmails + 1
Exit For
End If
Next j
Next
'lösche temporäre Spalte Z in Bibliothek
.Range("Z:Z").ClearContents
If MsgBox("Aktuelle Testgruppe als Email exportieren?" & vbCrLf & vbNewLine & _
foundEmails & " Ausbilder(innen) stehen im Verteiler:" & vbCrLf & vbNewLine & _
Replace(emailList, ";", vbCrLf), vbYesNo + vbQuestion) = vbYes Then
Else
Application.EnableEvents = True
Exit Sub
End If
End With
On Error GoTo 0
If rng Is Nothing Then
MsgBox "Auswahl ungültig." & _
vbNewLine & "Bitte erneut versuchen oder Blattschutz entfernen.", vbOKOnly
Exit Sub
End If
xMailBody = "[Anrede / Info-Block etc.]"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'On Error Resume Next
With OutMail
.To = emailList
.CC = ""
.BCC = ""
.Subject = "Information: Testgruppe gebildet"
.HTMLBody = xMailBody & RangetoHTML(rng)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
.Visible = True
End With
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
FileName:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function