SVERWEIS mit Makro: VLOOKUP

Makro erstellt ein neues WorkSheet, fügt die Daten aus dem Zwischenspeicher ein, setzt SVERWEIS-Formeln in die definierten Zellen, kopiert sie, fügt sie als Werte ein und löscht das erstellte Arbeitsblatt wieder.

Sub XYZABGLEICH()
If MsgBox("Gewuenschte Daten kopieren und je nach Zeilenanzahl vorher ggf. Range in VBA anpassen!", vbOKCancel, "XYZ-Abgleich") = vbOK Then
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Range("A:A,C:F,H:H,J:K").Select
Range("J1").Activate
Selection.Delete Shift:=xlToLeft
Sheets("ZielSheet").Select
Range("O2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC6,Tabelle1!C1:C3,2,FALSE)"
Range("P2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC6,Tabelle1!C1:C3,3,FALSE)"
Range("O2:P2").Select
Selection.AutoFill Destination:=Range("O2:P103")
Range("O2:P103").Select
Selection.Copy
Range("O2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Tabelle1").Select
ActiveWindow.SelectedSheets.Delete
Sheets("ZielSheet").Select
Range("O2").Select
Else
MsgBox "Abbruch, kein Abgleich vorgenommen!"
End If
End Sub

Datei mit bestimmtem Namen und Inhalt generieren

Sub ErzeugeACME()
Dim Dateiname As String
Dim ZellenInhalt As String
Dim x As String
If MsgBox("Text inkl. Trennlinien aus Terminal kopieren!", vbOKCancel, "Copy from Terminal") = vbOK Then
Range("A1").Select
ActiveSheet.Paste
Dateiname = Range("B8").Value
ZellenInhalt = Range("A4").Value
x = "C:\Temp\.well-known\acme-challenge\" & Dateiname
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(x, True)
a.WriteLine (ZellenInhalt)
a.Close
MsgBox "In C:\Temp\.well-known\acme-challenge\ gespeichert!"
Else
MsgBox "Aktion abgebrochen"
End If
End Sub

Dateien und Verzeichnisse inkl. Unterordner auslesen

Option Explicit
Option Compare Text
Const sRootPath As String = "C:\Temp"
Private lRowCounter As Long
Private oSheet As Object
Public Sub DateienMitUnterordnernAuslesen()
         Set oSheet = Sheets.Add
         oSheet.Activate
         oSheet.Cells(1, 1).Select
         Call CreateHeadLinesAndFormat
         lRowCounter = 2
         Call ReadSubFolder(sRootPath)
         Set oSheet = Nothing
End Sub
Private Sub CreateHeadLinesAndFormat()
   Dim i As Long
     oSheet.Cells(1, 1) = "Spalte1"
     oSheet.Cells(1, 2) = "Spalte2"
     oSheet.Columns(1).ColumnWidth = 40
     oSheet.Columns(2).ColumnWidth = 40
     For i = 1 To 2
         With oSheet
             .Cells(1, i).Interior.ColorIndex = 11
             .Cells(1, i).Font.Color = vbWhite
             .Cells(1, i).Font.Bold = True
         End With
     Next i
End Sub
Private Sub ReadSubFolder(ByVal sPath As String)
   Dim oFSO As Object
   Dim oFolder As Object
   Dim oSubFolder As Object
   Dim oFile As Object
     Set oFSO = CreateObject("Scripting.FileSystemObject")
     Set oFolder = oFSO.getfolder(sPath)
     With oSheet
         For Each oSubFolder In oFolder.subfolders
             For Each oFile In oSubFolder.Files
                 .Cells(lRowCounter, 1) = oSubFolder.Path
                 .Cells(lRowCounter, 2) = oFile.Name
                 lRowCounter = lRowCounter + 1
             Next oFile
            Call ReadSubFolder(oSubFolder.Path)
         Next oSubFolder
     End With
     Set oFSO = Nothing
     Set oFile = Nothing
     Set oFolder = Nothing
     Set oSubFolder = Nothing
End Sub