Bildschirmaufbau unterdrücken

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Rudi,
leider muss ich das tun.
Es geht hier um Mitgliedsadressen die an zwei unterschiedlichen Stellen eingegeben werden.
In meiner Adressen-Datei füge ich aber zusätzlich potentielle Mitglieder ein (die in der normalen Adressenliste nicht sein dürfen).
(Dabei ist meine Mitgliederliste im Gegenteil zu der einfachen Mitgliedereingabemaske- und Liste, die andere Mitarbeiter pflegen, ein Teil eines umfangreichen Systems)
Nach einer gewissen Zeit aktualisiere ich mein Gesamt-System. Dabei ergänze ich meine Adressendatei mit den Adressen der neu eingegebenen Mitglieder und hier greife ich eben auf die andere Datei zu.
Das ist der Hintergrund dazu.
Das Flackern ist leicht nervig, wenn es ab keine simple Lösung dazu gibt, dann flackerts eben.
Liebe Grüße,
Peter

Hallo Rudi,
so sieht er aus.

Sub MitgliederEinlesenNeu()
Dim arr As Variant
Dim iRow As Integer
Dim lz, ls, i, j, lz1, ls1 As Integer
Dim Mitgliedernr, bereitsvorhanden As String
Application.ScreenUpdating = False
'Öffnen der Originaladressen-Datei auf Laufwerk X
Workbooks.Open "X:\XYZ\Mitgliederadressen.xlsm"          'Pfad anpassen!
Worksheets("Mitglieder").Activate
'Letzte Zeile und Spalte in Mitgliederadressen bestimmen
lz = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row     'letzte Zeile bestimmen
ls = Cells(6, Columns.Count).End(xlToLeft).Column      'letzte Spalte bestimmen
For i = 1 To lz - 6
Application.ScreenUpdating = False
Windows("Mitgliederadressen.xlsm").Activate
Sheets("Mitglieder").Activate
Mitgliedernr = Cells(6 + i, 2)                          'Mitgliederadresse bestimmen
Range(Cells(6 + i, 2), Cells(6 + i, ls)).Select
Selection.Copy
'Zu XYZ springen
Application.ScreenUpdating = False
Windows("Metall_Chemie XYZ.xlsm").Activate
Sheets("Mitgliederanschrift").Activate
lz1 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row     'letzte Zeile im XYZ bestimmen
ls1 = Cells(10, Columns.Count).End(xlToLeft).Column      'letzte Spalteim XYZ bestimmen
bereitsvorhanden = "nein"
For j = 1 To lz1 - 10
If bereitsvorhanden = "ja" Then
Exit For
Else
'Überprüfen, ob der Kunde in Mitgliederadressen auch in
'STVer XYZ Mitgliederanschriften vorhanden ist
Dim ws As Worksheet, efz%, gef As Range
Set ws = ThisWorkbook.Worksheets("Mitgliederanschrift")
Set gef = ws.Range(Cells(11, 2), Cells(lz1, 2)).Find(Mitgliedernr)
If gef Is Nothing Then
'Wenn die Adresse im XYZ nicht vorhanden ist, dann wird sie ans Ende
'der Tabelle eingefügt
Application.ScreenUpdating = False
Windows("Mitgliederadressen.xlsm").Activate
Sheets("Mitglieder").Activate
Range(Cells(6 + i, 2), Cells(6 + i, ls)).Select
Selection.Copy
Application.ScreenUpdating = False
Windows("Metall_Chemie XYZ.xlsm").Activate
Sheets("Mitgliederanschrift").Activate
Range(Cells(lz1 + 1, 2), Cells(lz1 + 1, ls)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
'Wenn die Adresse im XYZ vorhanden ist, dann wird sie mit der Adresse
'aus Mitgliederadressen überschrieben
If Mitgliedernr = Cells(10 + j, 2) Then
Application.ScreenUpdating = False
Windows("Mitgliederadressen.xlsm").Activate
Sheets("Mitglieder").Activate
Range(Cells(6 + i, 2), Cells(6 + i, ls1)).Select
Selection.Copy
Application.ScreenUpdating = False
Windows("Metall_Chemie XYZ.xlsm").Activate
Sheets("Mitgliederanschrift").Activate
Range(Cells(10 + j, 2), Cells(10 + j, ls)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
bereitsvorhanden = "ja"
End If
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub

Sub MitgliederEinlesenNeu() Dim lz As Long, ls As Long, i As Long, j As Long, lz1 As Long, ls1 As Long Dim MitgliederNr, BereitsVorhanden As Boolean Dim wksMitgliederAdr As Worksheet, wksMitgliederMetChem As Worksheet Dim gef As Range Application.ScreenUpdating = False '1x reicht! 'Öffnen der Originaladressen-Datei auf Laufwerk X Set wksMitgliederAdr = Workbooks.Open("X:\XYZ\Mitgliederadressen.xlsm").Sheets("Mitglieder") _ 'Pfad anpassen! 'Letzte Zeile und Spalte in Mitgliederadressen bestimmen Set wksMitgliederMetChem = ThisWorkbook.Sheets("Mitgliederanschrift") With wksMitgliederAdr lz = .Cells(Rows.Count, 2).End(xlUp).Row 'letzte Zeile bestimmen ls = .Cells(6, Columns.Count).End(xlToLeft).Column 'letzte Spalte bestimmen End With For i = 1 To lz - 6 With wksMitgliederAdr MitgliederNr = .Cells(6 + i, 2) 'Mitgliederadresse bestimmen .Range(.Cells(6 + i, 2), .Cells(6 + i, ls)).Copy End With 'Zu XYZ springen With wksMitgliederMetChem lz1 = .Cells(Rows.Count, 2).End(xlUp).Row 'letzte Zeile im XYZ bestimmen ls1 = .Cells(10, Columns.Count).End(xlToLeft).Column 'letzte Spalteim XYZ bestimmen BereitsVorhanden = False For j = 1 To lz1 - 10 If BereitsVorhanden = True Then Exit For Else 'Überprüfen, ob der Kunde in Mitgliederadressen auch in 'STVer XYZ Mitgliederanschriften vorhanden ist Set gef = .Range(.Cells(11, 2), .Cells(lz1, 2)).Find(MitgliederNr) If gef Is Nothing Then 'Wenn die Adresse im XYZ nicht vorhanden ist, dann wird sie ans Ende 'der Tabelle eingefügt With wksMitgliederAdr .Range(.Cells(6 + i, 2), .Cells(6 + i, ls)).Copy End With .Range(.Cells(lz1 + 1, 2), .Cells(lz1 + 1, ls)).PasteSpecial _ Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False End If 'Wenn die Adresse im XYZ vorhanden ist, dann wird sie mit der Adresse 'aus Mitgliederadressen überschrieben If MitgliederNr = .Cells(10 + j, 2) Then With wksMitgliederAdr .Range(.Cells(6 + i, 2), .Cells(6 + i, ls1)).Copy End With .Range(.Cells(10 + j, 2), .Cells(10 + j, ls)).PasteSpecial _ Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False BereitsVorhanden = True End If End If Next j End With Next i End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread