Option Explicit
Const ForAppending = 8
Const TristateFalse = 0
Dim NotFirstWrite As Boolean
Dim IP_AddressRow As Long
Dim IP_RangesArrayRow As Long
Dim MaxRowsToPrint As Long
Dim TotalRows As Long
Dim FSO As Object, TS As Object
Dim strTempFile As String
Dim IP_RangesArray() As Variant
Dim FullOutputArray() As Variant
Dim DestinationWS As Worksheet
Sub ExpandIPs_VerticalV5()
Dim StartTime As Double
StartTime = Timer
Dim KeepResultsSheet As Boolean
Dim ResultsSheetMissing As Boolean
Dim ArrayColumn As Long
Dim SplitIP_Range As Long
Dim IP_AddressesToExpandArray() As String
Dim Lower_UpperIP_RangeArray() As String
Dim ResultSheetName As String
Dim OutputArrayForTxtFile() As Variant
Dim SourceWS As Worksheet
Set SourceWS = Sheets("Sheet1")
ResultSheetName = "Results Sheet"
KeepResultsSheet = False
strTempFile = "C:\Users\" & Environ("username") & "\Desktop\output.txt"
MaxRowsToPrint = 16000
Application.ScreenUpdating = False
If Dir(strTempFile) <> "" Then Kill strTempFile
ResultsSheetMissing = Evaluate("IsError(Cell(""col"",'" + ResultSheetName + "'!A1))")
If ResultsSheetMissing = False Then
Application.DisplayAlerts = False
Sheets(ResultSheetName).Delete
Application.DisplayAlerts = True
End If
Sheets.Add(After:=Sheets(Sheets.Count)).Name = ResultSheetName
Set DestinationWS = Sheets(ResultSheetName)
SourceWS.Columns("E:E").Replace " ", "", xlPart
NotFirstWrite = False
IP_RangesArray = SourceWS.Range("A1:F" & SourceWS.Range("E" & SourceWS.Rows.Count).End(xlUp).Row).Value2
ReDim FullOutputArray(1 To 16384, 1 To UBound(IP_RangesArray, 2))
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TS = FSO.OpenTextFile(strTempFile, ForAppending, True, TristateFalse)
For ArrayColumn = 2 To UBound(IP_RangesArray, 2)
FullOutputArray(1, ArrayColumn - 1) = IP_RangesArray(1, ArrayColumn) & " "
Next
IP_AddressRow = 1
TotalRows = 0
For IP_RangesArrayRow = 2 To UBound(IP_RangesArray, 1)
If IP_RangesArray(IP_RangesArrayRow, 1) <> 0 Then
If InStr(IP_RangesArray(IP_RangesArrayRow, 5), "-") > 0 Then
IP_AddressesToExpandArray = Split(IP_RangesArray(IP_RangesArrayRow, 5), ",")
For SplitIP_Range = 0 To UBound(IP_AddressesToExpandArray)
Lower_UpperIP_RangeArray = Split(IP_AddressesToExpandArray(SplitIP_Range), "-")
On Error Resume Next
Call SequenceIP_AddressRange_Vertical(Lower_UpperIP_RangeArray(0), Lower_UpperIP_RangeArray(1))
If Err.Number <> 0 Then
TotalRows = TotalRows + 1
IP_AddressRow = IP_AddressRow + 1
FullOutputArray(IP_AddressRow, 1) = IP_RangesArray(IP_RangesArrayRow, 2)
FullOutputArray(IP_AddressRow, 2) = IP_RangesArray(IP_RangesArrayRow, 3)
FullOutputArray(IP_AddressRow, 3) = IP_RangesArray(IP_RangesArrayRow, 4)
FullOutputArray(IP_AddressRow, 4) = Lower_UpperIP_RangeArray(0)
FullOutputArray(IP_AddressRow, 5) = Format(IP_RangesArray(IP_RangesArrayRow, 6), "m/d/yyyy")
On Error GoTo 0
End If
If IP_AddressRow = MaxRowsToPrint Then Call WriteToTextFile
Next
Else
TotalRows = TotalRows + 1
IP_AddressRow = IP_AddressRow + 1
FullOutputArray(IP_AddressRow, 1) = IP_RangesArray(IP_RangesArrayRow, 2)
FullOutputArray(IP_AddressRow, 2) = IP_RangesArray(IP_RangesArrayRow, 3)
FullOutputArray(IP_AddressRow, 3) = IP_RangesArray(IP_RangesArrayRow, 4)
FullOutputArray(IP_AddressRow, 4) = IP_RangesArray(IP_RangesArrayRow, 5)
FullOutputArray(IP_AddressRow, 5) = Format(IP_RangesArray(IP_RangesArrayRow, 6), "m/d/yyyy")
End If
If IP_AddressRow = MaxRowsToPrint Then Call WriteToTextFile
End If
Next
Call WriteToTextFile
If KeepResultsSheet = False Then
Application.DisplayAlerts = False
Sheets(ResultSheetName).Delete
Application.DisplayAlerts = True
Else
DestinationWS.UsedRange.EntireColumn.AutoFit
End If
TS.Close
Application.ScreenUpdating = True
Debug.Print "Completion Time for " & TotalRows & " rows = " & Timer - StartTime & " seconds."
MsgBox "Done!"
End Sub
Private Sub WriteToTextFile()
Dim ArrayColumn As Long
Dim ArrayRow As Long
Dim LastColumnNumberUsedInSheet As Long
Dim MaxCellLength As Long
Dim strData As String
FullOutputArray = Application.Transpose(FullOutputArray)
ReDim Preserve FullOutputArray(1 To UBound(FullOutputArray, 1), 1 To IP_AddressRow)
FullOutputArray = Application.Transpose(FullOutputArray)
DestinationWS.UsedRange.Clear
DestinationWS.Range("A1").Resize(UBound(FullOutputArray, 1), UBound(FullOutputArray, 2)) = FullOutputArray
ReDim OutputArrayForTxtFile(1 To UBound(FullOutputArray, 1), 1 To 1)
For ArrayColumn = 1 To UBound(FullOutputArray, 2)
MaxCellLength = 0
For ArrayRow = 1 To UBound(FullOutputArray, 1)
If MaxCellLength < Len(FullOutputArray(ArrayRow, ArrayColumn)) Then _
MaxCellLength = Len(FullOutputArray(ArrayRow, ArrayColumn))
Next
For ArrayRow = 1 To UBound(FullOutputArray, 1)
If OutputArrayForTxtFile(ArrayRow, 1) <> "" Then
OutputArrayForTxtFile(ArrayRow, 1) = OutputArrayForTxtFile(ArrayRow, 1) & _
FullOutputArray(ArrayRow, ArrayColumn) & Space(MaxCellLength - _
Len(FullOutputArray(ArrayRow, ArrayColumn)))
Else
OutputArrayForTxtFile(ArrayRow, 1) = FullOutputArray(ArrayRow, ArrayColumn) & _
Space(MaxCellLength - Len(FullOutputArray(ArrayRow, ArrayColumn)))
End If
Next
Next
LastColumnNumberUsedInSheet = DestinationWS.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
With DestinationWS
.Cells(1, LastColumnNumberUsedInSheet + 1).Resize(UBound(OutputArrayForTxtFile, 1)) = OutputArrayForTxtFile
If NotFirstWrite = True Then
DestinationWS.Cells(1, LastColumnNumberUsedInSheet + 1).Delete Shift:=xlUp
Else
NotFirstWrite = True
End If
.Cells(1, LastColumnNumberUsedInSheet + 1).Resize(UBound(OutputArrayForTxtFile, 1)).Copy
End With
strData = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("Text")
TS.Write strData
DestinationWS.Cells(1, LastColumnNumberUsedInSheet + 1).Resize(UBound(OutputArrayForTxtFile, 1)).Clear
ReDim FullOutputArray(1 To 16384, 1 To UBound(IP_RangesArray, 2))
For ArrayColumn = 2 To UBound(IP_RangesArray, 2)
FullOutputArray(1, ArrayColumn - 1) = IP_RangesArray(1, ArrayColumn) & " "
Next
IP_AddressRow = 1
End Sub
Sub SequenceIP_AddressRange_Vertical(LowerIP_Address As String, UpperIP_Address As String)
Dim b As Boolean
Dim OctetNumber As Long
Dim LowerIP_OctetsArray() As String
Dim UpperIP_OctetsArray() As String
LowerIP_OctetsArray = Split(LowerIP_Address, ".")
UpperIP_OctetsArray = Split(UpperIP_Address, ".")
Do Until Join(LowerIP_OctetsArray, ".") = Join(UpperIP_OctetsArray, ".")
If LowerIP_OctetsArray(3) = 256 Then
LowerIP_OctetsArray(3) = 0
LowerIP_OctetsArray(2) = LowerIP_OctetsArray(2) + 1
If LowerIP_OctetsArray(2) = 256 Then
LowerIP_OctetsArray(2) = 0
LowerIP_OctetsArray(1) = LowerIP_OctetsArray(1) + 1
If LowerIP_OctetsArray(1) = 256 Then
LowerIP_OctetsArray(1) = 0
LowerIP_OctetsArray(0) = LowerIP_OctetsArray(0) + 1
If LowerIP_OctetsArray(0) = 256 Then Exit Sub
End If
End If
End If
TotalRows = TotalRows + 1
IP_AddressRow = IP_AddressRow + 1
FullOutputArray(IP_AddressRow, 1) = IP_RangesArray(IP_RangesArrayRow, 2)
FullOutputArray(IP_AddressRow, 2) = IP_RangesArray(IP_RangesArrayRow, 3)
FullOutputArray(IP_AddressRow, 3) = IP_RangesArray(IP_RangesArrayRow, 4)
FullOutputArray(IP_AddressRow, 4) = Join(LowerIP_OctetsArray, ".")
FullOutputArray(IP_AddressRow, 5) = Format(IP_RangesArray(IP_RangesArrayRow, 6), "m/d/yyyy")
LowerIP_OctetsArray(3) = LowerIP_OctetsArray(3) + 1
If IP_AddressRow = MaxRowsToPrint Then Call WriteToTextFile
Loop
TotalRows = TotalRows + 1
IP_AddressRow = IP_AddressRow + 1
FullOutputArray(IP_AddressRow, 1) = IP_RangesArray(IP_RangesArrayRow, 2)
FullOutputArray(IP_AddressRow, 2) = IP_RangesArray(IP_RangesArrayRow, 3)
FullOutputArray(IP_AddressRow, 3) = IP_RangesArray(IP_RangesArrayRow, 4)
FullOutputArray(IP_AddressRow, 4) = Join(LowerIP_OctetsArray, ".")
FullOutputArray(IP_AddressRow, 5) = Format(IP_RangesArray(IP_RangesArrayRow, 6), "m/d/yyyy")
If IP_AddressRow = MaxRowsToPrint Then Call WriteToTextFile
End Sub