VBA Manually entered array - Zoidberg - arrays
I have VBA code that formats a range of cells, reads in a text file, converts the text in each cell to a color and in effect draws a picture of Zoidberg.
The problem I am having is the text file... I want to include the contents of the text file in the VBA as a manually entered array. That way I do not have to have the text file. This is strictly a memory burner.
The text file is the same thing as an array (in theory), so I should be able to define the array and do all the same things I am doing with the text file... but I'm missing something how do set up the array...
Sub Why_Not_Zoidberg()
' Insert Why Not Zoidberg?
'
'MAKE STUFF HAPPEN IN THE BACKGROUND
Application.ScreenUpdating = False
ActiveWindow.DisplayGridlines = False
'DEFINE VARIABLES
Dim Rng1 As Range
Dim i As Long
Dim j As Long
Dim nName As Name
'SET RANGE
Set Rng1 = Range("A1:BN48")
'CLEAR OUT ANY EXISTING JUNK
With Rng1
.Interior.ColorIndex = 0
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
ActiveSheet.Range("A1").Select
'IMPORT TEXT FILE
'With ActiveSheet.QueryTables.Add(Connection:= _
' "TEXT;C:\Windows\Zoidberg.txt", Destination:=Rng1 _
' )
' .Name = "Sample"
' .FieldNames = True
' .RowNumbers = False
' .FillAdjacentFormulas = False
' .PreserveFormatting = True
' .RefreshOnFileOpen = False
' .RefreshStyle = xlInsertDeleteCells
' .SavePassword = False
' .SaveData = True
' .AdjustColumnWidth = True
' .RefreshPeriod = 0
' .TextFilePromptOnRefresh = False
' .TextFilePlatform = 437
' .TextFileStartRow = 1
' .TextFileParseType = xlDelimited
' .TextFileTextQualifier = xlTextQualifierDoubleQuote
' .TextFileConsecutiveDelimiter = False
' .TextFileTabDelimiter = True
' .TextFileSemicolonDelimiter = False
' .TextFileCommaDelimiter = True
' .TextFileSpaceDelimiter = False
' .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
' .TextFileTrailingMinusNumbers = False
' .Refresh BackgroundQuery:=False
'End With
' ADD COLORS
For i = 1 To Rng1.Rows.Count
For j = 1 To Rng1.Columns.Count
If Rng1.Cells(i, j).Value = 3 Then
Rng1.Cells(i, j).Interior.Color = RGB(253, 3, 74)
End If
If Rng1.Cells(i, j).Value = -4142 Then
Rng1.Cells(i, j).Interior.Color = RGB(255, 255, 255)
End If
If Rng1.Cells(i, j).Value = 1 Then
Rng1.Cells(i, j).Interior.Color = RGB(1, 1, 1)
End If
If Rng1.Cells(i, j).Value = 14 Then
Rng1.Cells(i, j).Interior.Color = RGB(0, 153, 153)
End If
Next j
Next i
'CLEAR OUT TEXT FILE STUFF
Rng1.Select
With Rng1
.ClearContents
End With
Rng1.Select
'SET CELL SIZE
Selection.ColumnWidth = 2
Selection.RowHeight = 14.25
ActiveSheet.Range("A1").Select
'BREAK LINK TO EXTERNAL TEXT FILE
For Each nName In ActiveWorkbook.Names
If Left(nName.Name, 12) <> "" Then nName.Delete
Next nName
Application.ScreenUpdating = True
End Sub
Zoidberg.txt
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,1,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,3,3,3,3,3,3,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,1,3,3,3,3,3,3,1,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,1,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,1,3,3,3,3,3,3,3,1,1,1,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,1,3,3,1,1,1,1,1,1,-4142,-4142,1,1,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,1,3,1,1,1,-4142,-4142,1,1,1,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,1,1,-4142,1,1,-4142,-4142,1,3,3,1,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,1,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,1,-4142,-4142,-4142,-4142,1,3,3,3,3,3,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,1,1,1,1,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,1,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,1,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,1,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,1,3,3,1,3,3,1,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,1,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,1,3,3,3,1,3,1,3,3,1,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,1,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,1,1,1,3,3,1,3,3,1,3,3,1,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,1,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,1,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,1,1,1,3,3,1,3,3,1,3,3,1,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,1,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,1,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,1,3,3,3,1,3,1,3,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,1,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,1,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,1,3,3,3,3,3,3,3,3,3,3,3,1,3,3,1,3,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,1,-4142,-4142,1,3,3,3,3,3,3,3,1,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,1,3,3,3,3,3,3,3,3,3,3,3,1,3,1,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,1,1,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,1,1,1,3,3,3,3,3,3,3,3,3,3,1,3,3,3,1,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,1,14,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,14,1,-4142,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,1,14,14,14,14,14,14,14,14,14,14,14,1,14,14,14,14,1,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,14,14,14,14,14,14,14,14,14,14,1,14,14,14,14,1,-4142,-4142,-4142,-4142,1,1,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,14,14,14,14,14,14,14,14,14,1,14,14,14,14,1,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,14,14,14,14,14,14,14,14,14,1,1,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,-4142,-4142,-4142,1,1,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,1,1,1,1,1,1,1,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,1,-4142,1,1,3,3,3,3,3,3,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,-4142,-4142,-4142,1,3,3,3,3,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,1,1,1,1,1,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,1,-4142,1,1,1,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,1,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,1,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,1,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,1,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,1,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,1,1,1,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,1,1,1,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,3,3,3,3,3,3,3,3,3,3,3,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142,-4142
Every Excel worksheet is like a big 2d array. Depending on how you want to distribute the code, I'd store it in a worksheet. I copied and pasted your txt file into Excel - Paste Special - Text. Then I did Data - Text to Columns, delimited on Comma. Then I changed the code to this
Sub Why_Not_Zoidberg()
Dim Rng1 As Range
Dim i As Long, j As Long, k As Long
Dim nName As Name
ActiveWindow.DisplayGridlines = False
Set Rng1 = Range("A1:BN48")
With Rng1
.NumberFormat = ";;;" 'hide the values in the cells
.ColumnWidth = 2
.RowHeight = 14.25
.Interior.Color = RGB(255, 255, 255) 'white
End With
For i = 1 To Rng1.Rows.Count
For j = 1 To Rng1.Columns.Count
Select Case Rng1.Cells(i, j).Value
Case 3
Rng1.Cells(i, j).Interior.Color = RGB(253, 3, 74)
Case -4142
Rng1.Cells(i, j).Interior.Color = RGB(255, 255, 255)
Case 1
Rng1.Cells(i, j).Interior.Color = RGB(1, 1, 1)
Case 14
Rng1.Cells(i, j).Interior.Color = RGB(0, 153, 153)
End Select
For k = 1 To 100000: Next k 'adds a delay to animate
Next j
Next i
Rng1.Cells(1).Select
End Sub
I would manually enter all the ZoidDots... my text file... once this populates the cells, then run the other code we made up.
Sub ZoidArray()
Dim Inx As Long
Dim i As Long
Dim j As Long
Set Rng1 = Range("A1:BN48")
Dim ZoidDots() As Variant
ZoidDots = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
For i = 1 To Rng1.Rows.Count
For j = 1 To Rng1.Columns.Count
ActiveSheet.Cells(i, j).Select
With Selection
.Value = ZoidDots(j - 1)
End With
'For k = 1 To 1000000: Next k 'adds a delay to animate
Next j
Next i
End Sub
Related
Multiple Array Calculations
Script below runs a array difference calculation then processes the data further if other criteria is met. I need to add one additional criteria to filter the data further before it logs the final output to Sheet1. Need to add the "Location" in column "K" so it filters the data first before it logs it to Sheet1.
Code in Module 1
Public Sub PopulateMyArr()
myArr = Sheet4.Range("I6:I500").Value
End Sub
Code in This Workbook
Private Sub Workbook_Open()
PopulateMyArr
End Sub
Code in Sheet4 (BA_Size)
Private Sub Worksheet_Calculate()
Dim keyCells As Range, i As Long, diff, cKey As Range
'exit if togglebutton not on
If Not Worksheets("BA_Size").ToggleButton1.Value Then Exit Sub
On Error GoTo safeexit
Application.EnableEvents = False
Set keyCells = Me.Range("I6:I500")
nextrow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1
For i = 1 To UBound(myArr)
Set cKey = keyCells(i, 1)
If cKey.Value <> myArr(i, 1) Then
diff = (cKey.Value - myArr(i, 1))
'check value in Col L
Select Case cKey.EntireRow.Columns("L").Value
Case "John": diff = diff * cKey.EntireRow.Columns("O").Value
Case "Mary": diff = diff * cKey.EntireRow.Columns("P").Value
Case Else: diff = 0
End Select
Sheet1.Cells(nextrow, "A").Value = diff
nextrow = nextrow + 1
End If
Next i
safeexit:
PopulateMyArr
Application.EnableEvents = True
End Sub
Untested:
Private Sub Worksheet_Calculate()
Dim keyCells As Range, i As Long, diff, cKey As Range, kVal
'exit if togglebutton not on
If Not Worksheets("BA_Size").ToggleButton1.Value Then Exit Sub
On Error GoTo safeexit
Application.EnableEvents = False
Set keyCells = Me.Range("I6:I500")
nextrow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1
For i = 1 To UBound(myArr)
Set cKey = keyCells(i, 1)
kVal = cKey.EntireRow.Columns("K").Value ' << read from K
If kVal >= 0 And kVal <= 1 Then ' << check the value
If cKey.Value <> myArr(i, 1) Then
diff = (cKey.Value - myArr(i, 1))
'check value in Col L
Select Case cKey.EntireRow.Columns("L").Value
Case "John": diff = diff * cKey.EntireRow.Columns("O").Value
Case "Mary": diff = diff * cKey.EntireRow.Columns("P").Value
Case Else: diff = 0
End Select
Sheet1.Cells(nextrow, "A").Value = diff
nextrow = nextrow + 1
End If
End If 'K value is between 0 and 1
Next i
safeexit:
PopulateMyArr
Application.EnableEvents = True
End Sub
VBA: Subscript Out of Range - Size of array index is larger than array size
I created an array index (tickerIndex).
When I run the code, I get the error
subscript out of range
When I run the code, for some reason, the tickerIndex variable counts up to 13 which is 1 more than the size of the array.
The size of the tickers array is 12.
The tickerIndex variable is used to loop the tickers, tickerVolumes, tickerStartingPrices, and tickerEndingPrices arrays.
Dim tickers(12) As String
tickers(0) = "AY"
tickers(1) = "CSIQ"
tickers(2) = "DQ"
tickers(3) = "ENPH"
tickers(4) = "FSLR"
tickers(5) = "HASI"
tickers(6) = "JKS"
tickers(7) = "RUN"
tickers(8) = "SEDG"
tickers(9) = "SPWR"
tickers(10) = "TERP"
tickers(11) = "VSLR"
'Activate data worksheet
Worksheets(yearValue).Activate
'Get the number of rows to loop over
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
Dim tickerIndex As Integer
tickerIndex = 0
Dim tickerVolumes(12) As Long
Dim tickerStartingPrices(12) As Single
Dim tickerEndingPrices(12) As Single
For tickerIndex = 0 To 11
ticker = tickers(tickerIndex)
tickerVolumes(tickerIndex) = 0
Worksheets(yearValue).Activate
For i = 2 To RowCount
'Increase volume for current ticker [error on this line]
***If Cells(i, 1).Value = tickers(tickerIndex) Then***
tickerVolumes(tickerIndex) = tickerVolumes(tickerIndex) + Cells(i, 8).Value
End If
' Check if the current row is the first row with the selected tickerIndex.
If Cells(i - 1, 1).Value <> tickers(tickerIndex) And Cells(i, 1).Value = tickers(tickerIndex) Then
tickerStartingPrices(tickerIndex) = Cells(i, 6).Value
End If
'check if the current row is the last row with the selected ticker
'If the next row's ticker doesn't match, increase the tickerIndex.
If Cells(i + 1, 1).Value <> tickers(tickerIndex) And Cells(i, 1).Value = tickers(tickerIndex) Then
tickerEndingPrices(tickerIndex) = Cells(i, 6).Value
End If
'Increase the tickerIndex if the next row’s ticker doesn’t match the previous row’s ticker.
If Cells(i + 1, 1).Value <> Cells(i - 1, 1).Value Then
tickerIndex = tickerIndex + 1
End If
Next i
Next tickerIndex
'Loop through arrays to output the Ticker, Total Daily Volume, and Return.
For i = 0 To 11
Worksheets("AllStocksAnalysis").Activate
Cells(4 + i, 1).Value = tickers(tickerIndex)
Cells(4 + i, 2).Value = tickerVolumes(tickerIndex)
Cells(4 + i, 3).Value = (tickerEndingPrices(tickerIndex) / tickerStartingPrices(tickerIndex)) - 1
Next i
Don't hard code your array bounds. Do this For tickerIndex = LBound(tickers) To UBound(tickers) ticker = tickers(tickerIndex) ... or better yet this For Each ticker In tickers ... instead of this For tickerIndex = 0 To 11 ticker = tickers(tickerIndex) ...
Excel Split out Array for Different Colours
I had help with this code below, that works like a dream, it finds words from all 5 search textboxes and highlights them in red and adds a count to one of the columns. However i want to do the same but for box 1 word is in red and box 2 the word it finds it highlights in green and box 3 in orange etc etc. Is it possible to split out from the array which text box goes to which section of code, then could I change the second full set of loops to look for the word n the second textbox and make the word green?
I hope that makes sense?
Worksheets("Questions").Activate
Dim sPos As Long, sLen As Long
Dim SRrng As Range, cell2 As Range
Dim mywords As Variant
Dim i As Integer
Set SRrng = ActiveSheet.Range("B2:E4000")
mywords = Array(UsrFormSearch.TxtSearch1.Value, UsrFormSearch.TxtSearch2.Value,
UsrFormSearch.TxtSearch3.Value, UsrFormSearch.TxtSearch4.Value, UsrFormSearch.TxtSearch5.Value)
Dim m As Byte
Dim c As Range
Dim firstAddress As String
Dim CountArray() As Variant
ReDim CountArray(1 To SRrng.Rows.Count, 1 To 1)
For m = 0 To UBound(mywords)
With ActiveSheet.Range("B2:E4000")
Set c = .Find(mywords(m), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
For i = 1 To Len(c.Value)
sPos = InStr(i, c.Value, mywords(m))
sLen = Len(mywords(m))
If (sPos <> 0) Then
c.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
c.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
i = sPos + Len(mywords(m)) - 1
CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) = CountArray(c.Row - SRrng.Cells(1,
1).Row + 1, 1) + 1
End If
Next i
Set c = .FindNext(c)
If firstAddress = c.Address Then Exit Do
Loop While Not c Is Nothing
End If
End With
Next m
SRrng.Cells(1, 1).Offset(0, SRrng.Columns.Count).Resize(UBound(CountArray, 1), 1).Value2 = CountArray
Something like this would work. Just add in a second array of your RGB values which you can reference during each loop cycle.
Sub TestColor()
Worksheets("Questions").Activate
Dim sPos As Long, sLen As Long
Dim SRrng As Range, cell2 As Range
Dim mywords As Variant, myColors As Variant
Dim i As Integer
Set SRrng = ActiveSheet.Range("B2:E4000")
With UsrFormSearch ' Think the .Value is superfluous - add back in if issues arise
mywords = Array(.TxtSearch1, .TxtSearch2, .TxtSearch3, .TxtSearch4, .TxtSearch5)
End With
myColors = Array(RGB(255, 0, 0), RGB(0, 255, 0), RGB(255, 255, 0), RGB(255, 0, 255), RGB(0, 0, 255))
Dim m As Byte
Dim c As Range
Dim firstAddress As String
Dim CountArray() As Variant
ReDim CountArray(1 To SRrng.Rows.Count, 1 To 1)
For m = 0 To UBound(mywords)
With ActiveSheet.Range("B2:E4000")
Set c = .Find(mywords(m), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
For i = 1 To Len(c.Value)
sPos = InStr(i, c.Value, mywords(m))
sLen = Len(mywords(m))
If (sPos <> 0) Then
c.Characters(Start:=sPos, Length:=sLen).Font.Color = myColors(m)
c.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
i = sPos + Len(mywords(m)) - 1
CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) = CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) + 1
End If
Next i
Set c = .FindNext(c)
If firstAddress = c.Address Then Exit Do
Loop While Not c Is Nothing
End If
End With
Next m
SRrng.Cells(1, 1).Offset(0, SRrng.Columns.Count).Resize(UBound(CountArray, 1), 1).Value2 = CountArray
End Sub
Removing duplicates in a for loop crashes Excel
I have a for next loop that runs through a couple hundred thousand lines making changes on most. Could an array to make this code run faster?
The example of my for loop. Sometimes it gets overloaded and crashes Excel. (FYI my loop has to run bottom to top for it to do its intended purpose.)
Sub RemoveDuplicates()
Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Set wkb = ThisWorkbook
With wkb
Set shWorkBook = .Sheets("Workbook")
Set shFullYearData = .Sheets("FullYearData")
End With
Dim i As Long
Dim LastRowW As Long
On Error Resume Next
Call TurnOffCalc
FirstRowW = shWorkBook.Cells(1, 1).Row
FirstColW = shWorkBook.Cells(1, 1).Column
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
i = LastRowW
Sum = 0
shWorkBook.Activate
For i = LastRowW To 1 Step -1
If shWorkBook.Cells(i, 7) = shWorkBook.Cells(i - 1, 7) Then
shWorkBook.Cells(i, 26) = vbNullString
End If
If shWorkBook.Cells(i, 26).Value <> "" Then
shWorkBook.Cells(i, 27) = Sum + Cells(i, 25).Value
Sum = 0
ElseIf shWorkBook.Cells(i, 26).Value = "" Then
Sum = shWorkBook.Cells(i, 25).Value + Sum
End If
Next
p = FirstRowW + 1
For p = FirstRowW + 1 To LastRowW Step 1
shWorkBook.Cells(p, 28) = Application.WeekNum(shWorkBook.Cells(p, 3))
Next
shWorkBook.Cells(1, 28).Value = "Week Number"
Call TurnOnCalc
End Sub
Try something like this:
Sub RemoveDuplicates()
Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Dim i As Long, Sum
Dim LastRowW As Long, LastColW As Long, tbl As Range, data
Set wkb = ThisWorkbook
With wkb
Set shWorkBook = .Sheets("Workbook")
'Set shFullYearData = .Sheets("FullYearData")
End With
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
Set tbl = shWorkBook.Range("A1").Resize(LastRowW, 28) 'include "Week number" (?)
data = tbl.Value 'get the range value as an array
data(1, 28) = "Week Number"
Sum = 0
For i = LastRowW To 1 Step -1
If data(i, 7) = data(i - 1, 7) Then data(i, 26) = vbNullString
If data(i, 26).Value <> "" Then
data(i, 27) = Sum + data(i, 25).Value
Sum = 0
Else
Sum = data(i, 25).Value + Sum
End If
If i > 1 Then data(i, 28) = CLng(Format(data(i, 3), "ww"))
Next
tbl.Value = data 'return the data
End Sub
Count in numerical order only in blank (empty) cells
I'm trying to use VBA to auto fill (1, 2, 3, ....) in column "A" while skipping rows that are not blank/empty. For example, if there is text/data in "A3" and "A5", the code would count as follows:
"A1" = 1 "B1" = text/data
"A2" = 2 "B2" = text/data
"A3" = text/data "B3" = text/data
"A4" = 3 "B4" = text/data
"A5" = text/data "B5" = text/data
"A6" = 4 "B6" = text/data
"A7" = 5 "B7" = text/data
...and so on
So far I've only been able to skip the rows with previously entered text but that count continues as if it wasn't skipping any cells.
Please Note: I'm using .End(xlDown).Count in column "B" to define how far down the counter should go.
This is what I have so far
Sub Counter()
Dim NoF As Long
Dim Test As Long
NoF = Range("B1", Range("B1").End(xlDown)).Count
For i = 1 To NoF
If Cells(i, 1) = "" Then
ActiveSheet.Cells(i, 1).Value = i
ElseIf Cells(i, 1) <> "" Then
ActiveSheet.Cells(i, 1).Offset(i + 1, 1).Select
End If
Next i
End Sub
You could use a second variable which counts the rows with text. Initialize it outside of the for loop to zero and add 1 if there was some text. Next, you just need to subtract it from i.
j = 0
For i = 1 To NoF
If Cells(i, 1) = "" Then
ActiveSheet.Cells(i, 1).Value = i - j
ElseIf Cells(i, 1) <> "" Then
ActiveSheet.Cells(i, 1).Offset(i + 1, 1).Select
j = j + 1
End If
Next i
You do not need to Offset, this works as well
Option Explicit
Sub Counter()
Dim NoF As Long
Dim j As Long
Dim i As Long
NoF = Range("B1", Range("B1").End(xlDown)).Count
j = 0
For i = 1 To NoF
If Cells(i, 1) = "" Then
Cells(i, 1).Value = i - j
Else
j = j + 1
End If
Next i
End Sub