AW: Makro und Formeln zusammenführen
16.05.2024 12:43:11
schauan
So, jetzt habe ich mal meinen ersten code vervollständigt - weiterhin mit dem Anspruch, was per Aufzeichnen geht.
Lediglich beim Sortieren und dem Ausfüllen der Formeln habe ich eingegriffen. Bei beiden habe ich die Bereich bis Zeile 200 ausgedehnt - beim Aufzeichnen wird das auf vorhandene Größen eingeschränkt - und ActiveWorkbook.Worksheets("Tabelle_xx") habe ich durch ActiveSheet ersetzt. Das mit dem Blattnamen könnte man sich sparen, wenn man ein vorhandenes Blatt verwendet - im Original das Blatt Format oder bei Dir, Piet, die Quelldatei.
Und dann noch ,local:=true beim Speichern als csv wg. der Semikola....
Duplikate entfernen ist noch drin - diesmal aber über alle Spalten - falls doch mal ein "komplettes" Duplikat dabei ist.
Für's Zusammenfassen hab ich die vorhandene Formellösung beibehalten bzw. benutzt. Ich habe aber noch FILTER verwendet, um Leerzeilen auszuschließen - sonst kommt 1x als Ergebnis 0.
Sub Makro1()
'
' Makro1 Makro
'
'
Windows("169454.xlsx").Activate
Range("D:D,J:J,N:O").Select
Range("N1").Activate
Selection.Copy
Windows("169455.xlsm").Activate
Sheets.Add After:=ActiveSheet
' Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$D$7").RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
Header:=xlYes
Columns("B:B").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
ActiveCell.FormulaR1C1 = "code1"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Language"
Range("D1").Select
ActiveCell.FormulaR1C1 = "first_name"
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Columns("E:M").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add2 Key:=Range( _
"B2:B200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A1:D200")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("K2").Select
ActiveCell.Formula2R1C1 = "=UNIQUE(FILTER(RC[-8]:R[198]C[-8],RC[-8]:R[198]C[-8]>""""))"
Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(INDEX(R2C2:R2000C2,MATCH(RC[1],R2C3:R2000C3,0)),"""")"
Selection.AutoFill Destination:=Range("J2:J200"), Type:=xlFillDefault
Range("I2").Select
ActiveCell.Formula2R1C1 = _
"=IFERROR(TEXTJOIN("", "",TRUE,FILTER(R2C1:R2000C1,R2C3:R2000C3=RC[2])),"""")"
Selection.AutoFill Destination:=Range("I2:I200"), Type:=xlFillDefault
Range("L2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(RC[-1],R2C3:R[1998]C[-8],2,0),"""")"
Selection.AutoFill Destination:=Range("L2:L200"), Type:=xlFillDefault
Range("I2:L200").Select
Selection.Copy
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("E:M").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Move
ChDir "C:\Test"
ActiveWorkbook.SaveAs Filename:="C:\Test\169455.csv", _
FileFormat:=xlCSV, CreateBackup:=False, local:=True
ActiveWindow.Close
Windows("169454.xlsx").Activate
ActiveWindow.Close
End Sub