Option Explicit
Dim NotFirstWrite As Boolean
Dim IP_AddressRow As Long
Dim IP_RangesArrayRow As Long
Dim MaxRowsToPrint As Long
Dim strTempFile As String
Dim IP_RangesArray() As Variant
Dim FullOutputArray() As Variant
Dim DestinationWS As Worksheet
Sub ExpandIPs_VerticalV4()
'
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") ' <--- Set this to the proper sheet name to get the data from
ResultSheetName = "Results Sheet" ' <--- Set this to the name of the sheet to store results into. This will be
' ' a temporary sheet unless you choose to keep it for viewing afterwards
'
KeepResultsSheet = False ' <--- Set this to True to KeepResultsSheet, False to have it deleted when finished
strTempFile = "C:\Users\" & Environ("username") & "\Desktop\output.txt" ' <--- Set this to the Path & file name to save the results into
'
MaxRowsToPrint = 10000 ' <--- Set this to the number of rows to write to text file each time ... max = 16384
'
'---------------------------------------------------------------------------------------------------------------
'
Application.ScreenUpdating = False ' Turn ScreenUpdating off
'
If Dir(strTempFile) <> "" Then Kill strTempFile ' Delete the text file to write to if it exists
'
ResultsSheetMissing = Evaluate("IsError(Cell(""col"",'" + ResultSheetName + "'!A1))") ' If ResultsSheetMissing = False then the sheet does exist
'
If ResultsSheetMissing = False Then ' If the ResultSheetName exists then
Application.DisplayAlerts = False ' Turn DisplayAlerts off ... sheet deletion causes popup
Sheets(ResultSheetName).Delete ' Delete the sheet
Application.DisplayAlerts = True ' Turn DisplayAlerts back on
End If
'
Sheets.Add(After:=Sheets(Sheets.Count)).Name = ResultSheetName ' Add the ResultSheet & name it
'
Set DestinationWS = Sheets(ResultSheetName) ' Set the DestinationWS
'
SourceWS.Columns("E:E").Replace " ", "", xlPart ' Remove all spacea from IP ranges in column E
'
NotFirstWrite = False ' Set NotFirstWrite to False to indicate the FirstWrite will occur
'
IP_RangesArray = SourceWS.Range("A1:F" & SourceWS.Range("E" & SourceWS.Rows.Count).End(xlUp).Row).Value2 ' Load data into 2D 1 based IP_RangesArray
'
ReDim FullOutputArray(1 To 16384, 1 To UBound(IP_RangesArray, 2)) ' Establish size of FullOutputArray
'
'---------------------------------------------------------------------------------------------------------------
'
For ArrayColumn = 2 To UBound(IP_RangesArray, 2) ' Loop through columns of IP_RangesArray
FullOutputArray(1, ArrayColumn - 1) = IP_RangesArray(1, ArrayColumn) & " " ' Copy the Header to FullOutputArray
Next ' Loop back
'
IP_AddressRow = 1 ' Initialize the IP_AddressRow
'
For IP_RangesArrayRow = 2 To UBound(IP_RangesArray, 1) ' Loop through rows of IP_RangesArray
If IP_RangesArray(IP_RangesArrayRow, 1) <> 0 Then '
If InStr(IP_RangesArray(IP_RangesArrayRow, 5), "-") > 0 Then ' If the row contains '-' then ... IP range needs to be expanded
IP_AddressesToExpandArray = Split(IP_RangesArray(IP_RangesArrayRow, 5), ",") ' Split the AddressesToExpand according to commas
'
For SplitIP_Range = 0 To UBound(IP_AddressesToExpandArray) ' Loop through the 1D zero based IP_AddressesToExpandArray
Lower_UpperIP_RangeArray = Split(IP_AddressesToExpandArray(SplitIP_Range), "-") ' Split the IP_AddressesToExpand according to dashes
'
On Error Resume Next ' If error encountered, proceed to the next line of code
Call SequenceIP_AddressRange_Vertical(Lower_UpperIP_RangeArray(0), Lower_UpperIP_RangeArray(1)) '
If Err.Number <> 0 Then ' If an error occurred then no Lower_UpperIP_RangeArray(1) found ...
IP_AddressRow = IP_AddressRow + 1 ' Increment IP_AddressRow
FullOutputArray(IP_AddressRow, 1) = IP_RangesArray(IP_RangesArrayRow, 2) ' Save Owner to FullOutputArray
FullOutputArray(IP_AddressRow, 2) = IP_RangesArray(IP_RangesArrayRow, 3) ' Save Active to FullOutputArray
FullOutputArray(IP_AddressRow, 3) = IP_RangesArray(IP_RangesArrayRow, 4) ' Save Group to FullOutputArray
FullOutputArray(IP_AddressRow, 4) = Lower_UpperIP_RangeArray(0) ' Save IP address to FullOutputArray
FullOutputArray(IP_AddressRow, 5) = Format(IP_RangesArray(IP_RangesArrayRow, 6), "m/d/yyyy") ' Save exp to FullOutputArray
On Error GoTo 0 ' Clear errors & return error handling to Excel
End If
'
If IP_AddressRow = MaxRowsToPrint Then Call WriteToTextFile ' If we have reached the MaxRowsToPrint then write results to file
Next ' Loop back
Else ' Else ... Single IP address
IP_AddressRow = IP_AddressRow + 1 ' Increment IP_AddressRow
FullOutputArray(IP_AddressRow, 1) = IP_RangesArray(IP_RangesArrayRow, 2) ' Save Owner to FullOutputArray
FullOutputArray(IP_AddressRow, 2) = IP_RangesArray(IP_RangesArrayRow, 3) ' Save Active to FullOutputArray
FullOutputArray(IP_AddressRow, 3) = IP_RangesArray(IP_RangesArrayRow, 4) ' Save Group to FullOutputArray
FullOutputArray(IP_AddressRow, 4) = IP_RangesArray(IP_RangesArrayRow, 5) ' Save IP address to FullOutputArray
FullOutputArray(IP_AddressRow, 5) = Format(IP_RangesArray(IP_RangesArrayRow, 6), "m/d/yyyy") ' Save exp to FullOutputArray
End If
'
If IP_AddressRow = MaxRowsToPrint Then Call WriteToTextFile ' If we have reached the MaxRowsToPrint then write results to file
End If
Next ' Loop back
'
Call WriteToTextFile ' Write remaining results to file
'
'---------------------------------------------------------------------------------------------------------------
'
If KeepResultsSheet = False Then ' If user chose not to keep ResultsSheet then ...
Application.DisplayAlerts = False ' Turn DisplayAlerts off ... sheet deletion causes popup
Sheets(ResultSheetName).Delete ' Delete the ResultsSheet
Application.DisplayAlerts = True ' Turn DisplayAlerts back on
Else ' Else ...
DestinationWS.UsedRange.EntireColumn.AutoFit ' Fit all remaining data to columns in the destination sheetg
End If
'
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
'
MsgBox "Done!" ' Let the user know that the script has finished
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) ' Transpose the FullOutputArray for resizing
'
ReDim Preserve FullOutputArray(1 To UBound(FullOutputArray, 1), 1 To IP_AddressRow) ' Correct the size of FullOutputArray to actual number of rows needed
'
FullOutputArray = Application.Transpose(FullOutputArray) ' Transpose the FullOutputArray back
'
'---------------------------------------------------------------------------------------------------------------
'
DestinationWS.UsedRange.Clear ' Erase previous results from destination sheet
DestinationWS.Range("A1").Resize(UBound(FullOutputArray, 1), UBound(FullOutputArray, 2)) = FullOutputArray ' Display FullOutputArray to destination sheet
'
'---------------------------------------------------------------------------------------------------------------
'
' Convert FullOutputArray to a condensed 1 column array padded with spaces for nicer viewing in the text file
ReDim OutputArrayForTxtFile(1 To UBound(FullOutputArray, 1), 1 To 1) ' Establish size of OutputArrayForTxtFile
'
For ArrayColumn = 1 To UBound(FullOutputArray, 2) ' Loop through the columns of FullOutputArray
MaxCellLength = 0 ' Initialize MaxCellLength
'
For ArrayRow = 1 To UBound(FullOutputArray, 1) ' Loop through the rows of FullOutputArray
If MaxCellLength < Len(FullOutputArray(ArrayRow, ArrayColumn)) Then _
MaxCellLength = Len(FullOutputArray(ArrayRow, ArrayColumn)) ' Save largest character count of the cell values
Next ' Loop back
'
For ArrayRow = 1 To UBound(FullOutputArray, 1) ' Loop through the rows of FullOutputArray
If OutputArrayForTxtFile(ArrayRow, 1) <> "" Then ' If this is not the first column of FullOutputArray then ...
OutputArrayForTxtFile(ArrayRow, 1) = OutputArrayForTxtFile(ArrayRow, 1) & _
FullOutputArray(ArrayRow, ArrayColumn) & Space(MaxCellLength - _
Len(FullOutputArray(ArrayRow, ArrayColumn))) ' Make all of the character counts the same by adding any spaces needed
' ' then add it to previous column results
Else ' Else ...
OutputArrayForTxtFile(ArrayRow, 1) = FullOutputArray(ArrayRow, ArrayColumn) & _
Space(MaxCellLength - Len(FullOutputArray(ArrayRow, ArrayColumn))) ' Make all of the character counts the same by adding any spaces needed
End If
Next ' Loop back
Next ' Loop back
'
'---------------------------------------------------------------------------------------------------------------
'
' Display OutputArrayForTxtFile to sheet, copy it, write it to text file, delete it from sheet
LastColumnNumberUsedInSheet = DestinationWS.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column ' Get LastColumnNumberUsedInSheet
'
With DestinationWS
.Cells(1, LastColumnNumberUsedInSheet + 1).Resize(UBound(OutputArrayForTxtFile, 1)) = OutputArrayForTxtFile ' Display OutputArrayForTxtFile to destination sheet
'
If NotFirstWrite = True Then ' If this isn't the first write to the text file then ...
DestinationWS.Cells(1, LastColumnNumberUsedInSheet + 1).Delete Shift:=xlUp ' delete the header row from results
Else ' Else ...
NotFirstWrite = True ' Set NotFirstWrite to True for future writes to text file
End If
'
.Cells(1, LastColumnNumberUsedInSheet + 1).Resize(UBound(OutputArrayForTxtFile, 1)).Copy ' Copy data needed for .txt file to clipboard
End With
'
strData = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("Text") ' Save contents of clipboard into strData
'
'
' CreateObject("Scripting.FileSystemObject").CreateTextFile(strTempFile, True).Write strData ' Write the data to file, overwrite data if file already exists
CreateObject("Scripting.FileSystemObject").OpenTextFile(strTempFile, 8, True, 0).Write strData ' Write the data to file, append data if file already exists
'
DestinationWS.Cells(1, LastColumnNumberUsedInSheet + 1).Resize(UBound(OutputArrayForTxtFile, 1)).Clear ' Erase the data used for the .txt file from the destination sheet
'
'---------------------------------------------------------------------------------------------------------------
'
ReDim FullOutputArray(1 To 16384, 1 To UBound(IP_RangesArray, 2)) ' Erase & establish size of FullOutputArray
'
For ArrayColumn = 2 To UBound(IP_RangesArray, 2) ' Loop through columns of IP_RangesArray
FullOutputArray(1, ArrayColumn - 1) = IP_RangesArray(1, ArrayColumn) & " " ' Copy the Header to FullOutputArray
Next ' Loop back
'
IP_AddressRow = 1 ' Reset the IP_AddressRow
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, ".") ' Split the LowerIP_Address into octets according to '.' found
UpperIP_OctetsArray = Split(UpperIP_Address, ".") ' Split the UpperIP_Address into octets according to '.' found
'
b = True ' Set boolean flag b to True, this line may not be required
'
Do Until Join(LowerIP_OctetsArray, ".") = Join(UpperIP_OctetsArray, ".") ' Loop until LowerIP_Address = UpperIP_Address
b = True ' Set boolean flag b to true
'
For OctetNumber = 1 To 3 ' Loop
If LowerIP_OctetsArray(OctetNumber) = 256 Then ' If OctetNumber value = 256 then ...
LowerIP_OctetsArray(OctetNumber - 1) = LowerIP_OctetsArray(OctetNumber - 1) + 1 ' Increment the next higher OctetNumber value
LowerIP_OctetsArray(OctetNumber) = 0 ' Set OctetNumber value to zero
'
b = False ' Set boolean flag b to False
End If
Next ' Loop back
'
IP_AddressRow = IP_AddressRow + 1 ' Increment IP_AddressRow
FullOutputArray(IP_AddressRow, 1) = IP_RangesArray(IP_RangesArrayRow, 2) ' Save Owner to FullOutputArray
FullOutputArray(IP_AddressRow, 2) = IP_RangesArray(IP_RangesArrayRow, 3) ' Save Active to FullOutputArray
FullOutputArray(IP_AddressRow, 3) = IP_RangesArray(IP_RangesArrayRow, 4) ' Save Group to FullOutputArray
FullOutputArray(IP_AddressRow, 4) = Join(LowerIP_OctetsArray, ".") ' Save IP address to FullOutputArray
FullOutputArray(IP_AddressRow, 5) = Format(IP_RangesArray(IP_RangesArrayRow, 6), "m/d/yyyy") ' Save exp to FullOutputArray
'
If b Then LowerIP_OctetsArray(3) = LowerIP_OctetsArray(3) + 1 ' Increment Octet 1 value
'
If IP_AddressRow = MaxRowsToPrint Then Call WriteToTextFile ' If we have reached the MaxRowsToPrint then write results to file
Loop ' Loop back
'
IP_AddressRow = IP_AddressRow + 1 ' Increment IP_AddressRow
FullOutputArray(IP_AddressRow, 1) = IP_RangesArray(IP_RangesArrayRow, 2) ' Save Owner to FullOutputArray
FullOutputArray(IP_AddressRow, 2) = IP_RangesArray(IP_RangesArrayRow, 3) ' Save Active to FullOutputArray
FullOutputArray(IP_AddressRow, 3) = IP_RangesArray(IP_RangesArrayRow, 4) ' Save Group to FullOutputArray
FullOutputArray(IP_AddressRow, 4) = Join(LowerIP_OctetsArray, ".") ' Save IP address to FullOutputArray
FullOutputArray(IP_AddressRow, 5) = Format(IP_RangesArray(IP_RangesArrayRow, 6), "m/d/yyyy") ' Save exp to FullOutputArray
'
If IP_AddressRow = MaxRowsToPrint Then Call WriteToTextFile ' If we have reached the MaxRowsToPrint then write results to file
End Sub
Hopefully you don't encounter such a wide range in your testing.
