VBA - Zeilen nach Zahl/Variable hinzufügen und Werte kopiere
24.10.2023 17:21:12
Annette
ich hoffe, es kann jemand helfen? Ich würde mich freuen. Liebe Grüße
In einer Datei sind Emailadressen und weitere Infos enthalten. Um sie in ein System zu importieren benötige ich sie separiert und als einzelne Zeilen:
https://www.herber.de/bbs/user/163693.xlsx
Beispiel siehe Beispieldatei oder hier:
Emailadresse1 Referenz1, Referenz2, Referenz3 ... Häufigkeit3
Emailadresse2 Referenz1, Referenz2 ... Häufigkeit2
Emailadresse3 Referenz1 ... Häufigkeit1
Ich suche ein Makro, dass folgendes macht:
Ist die Häufigkeit 3, füge 2 Zeilen hinzu und kopiere die Information aus der Zeile in die kopierten (neuen) Zeilen.
Ist die Häufigkeit 2, füge 1 Zeilen hinzu und kopiere die Information aus der Zeile in die kopierten (neuen) Zeilen.
Ist die Häufigkeit 1 - mache nix.
Anzahl Zeilen mal 400 oder 1000
Ziel also:
Emailadresse1 Referenz1, Referenz2, Referenz3 ... Häufigkeit3
Emailadresse1 Referenz1, Referenz2, Referenz3 ... Häufigkeit3
Emailadresse1 Referenz1, Referenz2, Referenz3 ... Häufigkeit3
Emailadresse2 Referenz1, Referenz2 ... Häufigkeit2
Emailadresse2 Referenz1, Referenz2 ... Häufigkeit2
Emailadresse3 Referenz1 ... Häufigkeit1
Später, dann vermutlich in einem anderen Schritt muss ich das noch daraus basteln, wenn das auch noch jemand weiß, dann gerne. :-)
Emailadresse1 Referenz1 ... Häufigkeit3
Emailadresse1 Referenz2 ... Häufigkeit3
Emailadresse1 Referenz3 ... Häufigkeit3
Emailadresse2 Referenz1 ... Häufigkeit2
Emailadresse2 Referenz2 ... Häufigkeit2
Emailadresse3 Referenz1 ... Häufigkeit1
Aktuell sieht es bei mir so aus (manche Zeilen die mir helfen, können sicher noch raus):
Sub Zeilen_hinzufuegen()
On Error GoTo FehlerBehandlung
'das Makro sucht in nach Trenungszeichen , und fügt entsprechend Zeilen hinzu
Dim wrkbook As Workbook
Dim wkssheet As Worksheet
Dim wksziel As Worksheet
Dim rngBereich As Range
Dim rngbereichZiel As Range
Dim rngZelleZiel As Range
Dim intSpalte As Integer
Dim intzaehler As Integer
Dim intzeilenzaehler As Integer
Dim intVork As Integer
'-------------------------PFAD Angeben----------------------------
Set wrkbook = Application.Workbooks.Open("C:\Users\Kurz\Desktop\Kurz\Adressverwaltung_Opt\Anfragen_KUP\Werbesperren\Übersicht Werbesperren_Test_Auslesen.xlsm")
'----------------------------------------------
Set wkssheet = wrkbook.Worksheets("Emailadressen")
wkssheet.Select
Set rngBereich = wkssheet.UsedRange
Set wksziel = wrkbook.Worksheets.Add
wksziel.Name = "Emailadressen_neu"
wkssheet.UsedRange.Copy
' wksziel.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False 'Zwischenspeicher löschen
With wksziel
.Cells.Select
.Cells.EntireColumn.AutoFit
.Range("A1").Select
End With
Set rngbereichZiel = wksziel.UsedRange
intzeilenzaehler = rngbereichZiel.Rows.Count 'Anzahl Zeilen
intSpalte = rngbereichZiel.Columns.Count
rngbereichZiel.Select
Debug.Print rngbereichZiel.Address
Debug.Print "xxx"
For Each rngZelleZiel In rngbereichZiel
Select Case rngZelleZiel
Case 3
intzaehler = rngZelleZiel.Row
Debug.Print intzaehler
' rngZelleZiel(intzaehler, 4).EntireRow.Insert
' rngZelleZiel(intzaehler, 4).EntireRow.Insert
Case 2
'rngZelleZiel(intzaehler, 4).EntireRow.Insert
'Rows("intzaehler:intzaehler+2").Insert
Debug.Print "Case 2"
'Typen unverträglich weil #NV?'
Case "#NV"
Debug.Print "#NV"
Case Else
End Select
Next
'
ExitTeil:
On Error Resume Next
Set wrkbook = Nothing
Set wkssheet = Nothing
Set wksziel = Nothing
Set rngBereich = Nothing
Set rngZelle = Nothing
Set rngZelleZiel = Nothing
Set rngbereichZiel = Nothing
Exit Sub
FehlerBehandlung:
MsgBox "FehlerNr.: " & Err.Number & vbTab & Err.Description, vbCritical, pc_Titel
Err.Clear
Resume ExitTeil