May 19, 2017, updated at 19:03:57 (UTC)

1251

VBA Excel Skript - Hilfe!

Hallo Ihr,

leider habe Schwierigkeiten bei einem alten VBA Skript. Ich habe es mal für Excel in der Schule erstellt, vor Jahren. Daher weiß ich leider nicht mehr genau, was es genau macht. Kann mir wer helfen,und sagen,was es macht?

Public Sub Ausführen(control As IRibbonControl)
Dim variableI As Long
Dim variableX As Long
Dim variableN As Long
Dim i As Long
Dim x As Long
Dim varI As Long
Dim varX As Long
ActiveSheet.Name = "Adressen067"  

Dim wb As Workbook
Set wb = Workbooks.Add
wb.SaveAs Filename:="C:\Test\NeueAdressen.xlsx"  
'Workbooks("NeueAdressen3.xlsx").Close  
Workbooks("adress.xls").Activate  
variableX = Cells(Rows.Count, 23).End(xlUp).Row
variableN = 2
'Workbooks.Open ("NeueAdressen3.xlsx")  
Rows(1).Copy Destination:=Workbooks("NeueAdressen.xlsx").Worksheets("Tabelle1").Rows(1)  
For variableI = 2 To variableX
    
        If Cells(variableI, 23) <> "" Then  
            
            Rows(variableI).Cut Destination:=Workbooks("NeueAdressen.xlsx").Worksheets("Tabelle1").Rows(variableN)  
            variableN = variableN + 1
        
        End If
Next variableI
Workbooks("NeueAdressen.xlsx").Activate  
Dim variI
Dim variX
Cells(1, 23).ClearContents
variX = Cells(Rows.Count, 23).End(xlUp).Row
For variI = 2 To variX
    If Cells(variI, 22) <> "" Then  
        Cells(variI, 22) = Cells(variI, 22) & " " & Cells(variI, 23)  
        Cells(variI, 23).ClearContents
        Range(Cells(variI, 22), Cells(variI, 23)).Merge
    End If
Next variI
Columns(22).AutoFit
Dim vI
Dim vX
vX = Cells(Rows.Count, 31).End(xlUp).Row
Range("AF1") = "Neu?"  
For vI = 2 To vX
    If Cells(vI, 32) = "" Then  
        Range("AF" & vI) = "1"  
    End If
Next vI
Workbooks("NeueAdressen.xlsx").Close  
'End With  
x = Cells(Rows.Count, 31).End(xlUp).Row
For i = x To 2 Step -1
    
        If Cells(i, 31) = "" Then  
 
            Rows(i).Delete Shift:=xlUp
   
        End If
    
Next i
'ThisWorkbook.Sheet("adress01").Select  
varX = Cells(Rows.Count, 31).End(xlUp).Row
Range("AF1") = "Gesperrt09"  
For varI = 2 To varX
    If Cells(varI, 32) = "" Then  
        Range("AF" & varI) = "1"  
    End If
Next varI
End Sub

Gruß

Please also mark the comments that contributed to the solution of the article

Content-Key: 338357

Url: https://administrator.de/contentid/338357

Printed on: April 19, 2024 at 18:04 o'clock

1 Comment

Tja, hätte man seinen Code kommentiert ;-P...

Zitat von @133202:
Public Sub Ausführen(control As IRibbonControl)
Dim variableI As Long
Dim variableX As Long
Dim variableN As Long
Dim i As Long
Dim x As Long
Dim varI As Long
Dim varX As Long

Variablen definieren, hoffentlich verstehst du das wenigstens noch

ActiveSheet.Name = "Adressen067"

Benennt das aktive Sheet um.

Dim wb As Workbook
Set wb = Workbooks.Add
wb.SaveAs Filename:="C:\Test\NeueAdressen.xlsx"

Legt eine neue Arbeitsmappe an und speichert sie.

Workbooks("adress.xls").Activate

Aktiviert das Sheet mit dem Namen adress.xls.

variableX = Cells(Rows.Count, 23).End(xlUp).Row

Ermittelt die letzte belegte Zelle in Spalte 23 und speichert die Zeilennummer in der Variablen "variableX"

variableN = 2
Rows(1).Copy Destination:=Workbooks("NeueAdressen.xlsx").Worksheets("Tabelle1").Rows(1)

Kopiert die ganze erste Zeile des aktiven Sheets in das Workbook NeueAdressen.xlsx in Tabelle1.

For variableI = 2 To variableX

If Cells(variableI, 23) <> "" Then

Rows(variableI).Cut Destination:=Workbooks("NeueAdressen.xlsx").Worksheets("Tabelle1").Rows(variableN)
variableN = variableN + 1

End If
Next variableI

Durchläuft alle Zellen von Zeile 2 bis zu ermittelten letzten belegten Zelle in Spalte 23 und prüft ob die Zelle nicht leer ist. Wenn ja dann kopiert es diese ganze Zeile ebenfalls in das Workbook NeueAdressen.xlsx untereinander.

Workbooks("NeueAdressen.xlsx").Activate

Aktiviert das angegebene Workbook

Dim variI
Dim variX
Cells(1, 23).ClearContents

Löscht den Inhalt von Zelle 1 in Spalte 23.

variX = Cells(Rows.Count, 23).End(xlUp).Row

Ermittelt erneut die letzte belegte Zelle in Spalte 23.

For variI = 2 To variX
If Cells(variI, 22) <> "" Then
Cells(variI, 22) = Cells(variI, 22) & " " & Cells(variI, 23)
Cells(variI, 23).ClearContents
Range(Cells(variI, 22), Cells(variI, 23)).Merge
End If
Next variI

Durchläuft erneut mit der Schleife alle Zellen, prüft ob Spalte 22 nicht leer ist, und wenn ja kombinier es den Inhalt von Spalte 22 und 23 und setzt den Inhalt in Spalte 22, löscht dann den Inhalt von Spalte 23, und macht die Spalten 22 und 23 zu einer einzigen Zelle.

Columns(22).AutoFit

Passt die Spaltenbreite der Spalte 22 automatisch an die Inhalte an.

Dim vI
Dim vX
vX = Cells(Rows.Count, 31).End(xlUp).Row

Wieder Ermittlungen der letzten Zelle in Spalte 31

Range("AF1") = "Neu?"
For vI = 2 To vX
If Cells(vI, 32) = "" Then
Range("AF" & vI) = "1"
End If
Next vI

Durchlaufe wieder mit Schleife alle Zellen von 2 bis Ende Spalte 31, wenn dabei Spalte 32 leer ist setze den Inhalt von AFx (x = aktuelle Zeile der Schleife) auf 1.

Workbooks("NeueAdressen.xlsx").Close

Schließe das Workbook.

x = Cells(Rows.Count, 31).End(xlUp).Row
For i = x To 2 Step -1

If Cells(i, 31) = "" Then

Rows(i).Delete Shift:=xlUp

End If

Next i

Durchlaufe mit Schleife alle Zellen von Ende Spalte 31 bis Zeile 2, diesmal rückwärts, wenn dabei Spalte 31 leer ist lösche die ganze Zeile.

varX = Cells(Rows.Count, 31).End(xlUp).Row
Range("AF1") = "Gesperrt09"

Setze Inhalt von AF1 auf "Gesperrt09"

For varI = 2 To varX
If Cells(varI, 32) = "" Then
Range("AF" & varI) = "1"
End If
Next varI
End Sub

Durchlaufe wieder mit Schleife (wird langsam eintönig) alle Zellen von Zeile 2 bis Ende Spalte 31, wenn dabei Spalte 32 leer ist setze den Inhalt von AFx (x = aktuelle Zeile der Schleife) auf 1.

Habe fertig, nu bist du am Zug deine VBA Kenntnisse wieder auf den aktuellen Stand zu bringen.

Gruß

German solved Question VB for Applications Development

Hotly discussed

Check of ZFW Firewallgleixnerd - 3 Comments

How to set up and configure a Linux GRE tunnelAlexWisha - 3 Comments

WIREGUARD VPN ON UDM PRO BEHIND FRITZBOX - HANDSHAKE DID NOT COMPLETEjstricker - 3 Comments

End of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment