Category: Excel VBA

Der folgende VBA-Code formatiert jede Zelle, die eine Änderung erfährt, mit roter Textfarbe:

Private Sub Worksheet_Change(ByVal Target as Range)
    Target.Font.ColorIndex = 3
End Sub

VBA ist die Abkürzung für Visual Basic for Applications.

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

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

Sub SpalteAloeschen()
Columns("A:A").Select
Selection.ClearContents
Range("A1").Select
End Sub

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

Ausgabe in G1

Sub BereichVerketten()
Dim c As Range, tmp As String
For Each c In Selection
  tmp = tmp & c & "', '"
Next
tmp = Left(tmp, Len(tmp) - 1)
[g1] = tmp
End Sub

Bezogen auf einen bestimmten Bereich im VBA-Projekt:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Range("D3:D5,E3:E5")) Is Nothing Then
If Target.Value > 0 Then
If Target.Value < 0.82 Then
MsgBox "Bitte........"
End If
End If
End If
End Sub