Related
I'm working on a sub where, after doing a whole bunch of other things, it just selects all the cells in the active sheet and sets the rows to auto-fit height. For some reason it won't work! I've tried to the autofit row height command in various different places, but it seems that so long as it's part of the larger sub, or called within it, it won't work. However, if I write a separate sub that is run separately, it will work just fine. Does anyone know why this could be?
Below is the sub where it's misbehaving, plus the other sub I made that I can run separately. Any suggestions on how to make this all more efficient is also very welcome! (I also kind of learned coding in the wild, so I don't really know best practices...)
Option Explicit
Sub WriteToIndex(ByRef rowsArray() As Variant, ByRef Indexes() As Integer, ByRef HeaderNames() As String, myTable As ListObject, sheetName As String)
Debug.Print sheetName
Sheets(sheetName).Activate
Dim i, j As Variant
Dim count As Integer
'If no rows, no write
If (Not Not rowsArray) <> 0 Then
Else:
'If the index is longer than 5000 rows, this will need to be updated!
Range("B4:L5000").Clear
MsgBox "Sheet " & sheetName & " was not populated because there is nothing attributed to it"
Exit Sub
End If
'If nothing in Int/Ext section, no write
count = 0
For i = LBound(rowsArray) To UBound(rowsArray)
For j = LBound(Indexes) To UBound(Indexes)
If myTable.DataBodyRange(rowsArray(i), Indexes(j)).Value = "n" Then count = count + 1
Next
Next
If count = 0 Then
'If the index is longer than 5000 rows, this will need to be updated!
Range("B4:L5000").Clear
MsgBox "Sheet " & sheetName & " was not populated because there is nothing attributed to it"
Exit Sub
End If
Sheets(sheetName).Activate
'Pulls desired index fonts and sizes from Settings tab
Dim IndexFont As String, HeaderFSize, BodyFSize As Integer, HeaderBold As Boolean
IndexFont = Worksheets("Settings").Cells(10, 11).Value
HeaderFSize = Worksheets("Settings").Cells(11, 11).Value
HeaderBold = Worksheets("Settings").Cells(12, 11).Value
BodyFSize = Worksheets("Settings").Cells(13, 11).Value
'Remove headers from array if there are no items for the index
Dim loopno, pos, zeroloops(), zeroloopstart As Integer
count = 0
zeroloopstart = 0
loopno = 1
ReDim Preserve zeroloops(zeroloopstart)
For i = LBound(Indexes) To UBound(Indexes)
For j = LBound(rowsArray) To UBound(rowsArray)
If myTable.DataBodyRange(rowsArray(j), Indexes(i)).Text = "n" Then count = count + 1
Next
If count = 0 Then
pos = loopno - 1
ReDim Preserve zeroloops(0 To zeroloopstart)
zeroloops(zeroloopstart) = pos
zeroloopstart = zeroloopstart + 1
End If
count = 0
loopno = loopno + 1
Next
'If a header is in the zeroloops array, it gets removed from the Header array
If IsEmpty(zeroloops(0)) Then
Debug.Print "Empty"
Else
For i = LBound(zeroloops) To UBound(zeroloops)
For j = zeroloops(i) To UBound(Indexes) - 1
Indexes(j) = Indexes(j + 1)
Next j
For j = zeroloops(i) To UBound(HeaderNames) - 1
HeaderNames(j) = HeaderNames(j + 1)
Next j
For j = LBound(zeroloops) To UBound(zeroloops)
zeroloops(j) = zeroloops(j) - 1
Next j
Debug.Print
ReDim Preserve Indexes(0 To (UBound(Indexes) - 1))
ReDim Preserve HeaderNames(0 To (UBound(HeaderNames) - 1))
Next i
End If
'If the index is longer than 5000 rows, this will need to be updated!
Range("B4:L5000").Clear
'Apply preferred font to entire sheet
Cells.Font.Name = IndexFont
Dim KeyIDCol, DescCol, SourceCol, ProductCol, CatCol, ColorCol, FinishCol, SizeCol, ContactCol, SpecCol, RemarkCol As Integer
'Index for each value to report
'If additional column needs to be reported, add the line and swap out the name in the Listcolumns definition
KeyIDCol = Worksheets("Database").ListObjects("Database").ListColumns("KEYNOTE #").Index
DescCol = Worksheets("Database").ListObjects("Database").ListColumns("KEYNOTE DESCRIPTION").Index
SourceCol = Worksheets("Database").ListObjects("Database").ListColumns("SOURCE").Index
ProductCol = Worksheets("Database").ListObjects("Database").ListColumns("PRODUCT").Index
CatCol = Worksheets("Database").ListObjects("Database").ListColumns("CAT. NO.").Index
ColorCol = Worksheets("Database").ListObjects("Database").ListColumns("COLOR").Index
FinishCol = Worksheets("Database").ListObjects("Database").ListColumns("FINISH").Index
SizeCol = Worksheets("Database").ListObjects("Database").ListColumns("SIZE").Index
ContactCol = Worksheets("Database").ListObjects("Database").ListColumns("CONTACT").Index
SpecCol = Worksheets("Database").ListObjects("Database").ListColumns("SECTION #").Index
RemarkCol = Worksheets("Database").ListObjects("Database").ListColumns("REMARKS").Index
'Definitions for write loop
Dim NextWriteRow, HeaderListIndex As Integer
Dim ArrayItem As Variant
Dim WriteStartCell, Cell As Range
NextWriteRow = 4
HeaderListIndex = 0
i = 1 ' for moving to the next KeyID
j = 0 ' start counter for steps
Set WriteStartCell = Cells(NextWriteRow, 2)
Dim k As Variant
'Outer loop puts in headers
For Each ArrayItem In Indexes
With Cells(NextWriteRow, 2)
.Value = HeaderNames(HeaderListIndex)
.VerticalAlignment = xlBottom
.Font.Size = HeaderFSize
.Font.Bold = HeaderBold
End With
HeaderListIndex = HeaderListIndex + 1
'Second loop puts in KeynoteID with all pertinent info
For k = LBound(rowsArray) To UBound(rowsArray)
If myTable.DataBodyRange(rowsArray(k), ArrayItem).Value = "n" Then
With WriteStartCell
.Offset(i, 0).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, KeyIDCol - ArrayItem).Value
.Offset(i, 1).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, DescCol - ArrayItem).Value
.Offset(i, 2).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, SourceCol - ArrayItem).Value
.Offset(i, 3).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, ProductCol - ArrayItem).Value
.Offset(i, 4).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, CatCol - ArrayItem).Value
.Offset(i, 5).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, ColorCol - ArrayItem).Value
.Offset(i, 6).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, FinishCol - ArrayItem).Value
.Offset(i, 7).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, SizeCol - ArrayItem).Value
.Offset(i, 8).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, ContactCol - ArrayItem).Value
With .Offset(i, 9)
.NumberFormat = "000000"
.HorizontalAlignment = xlCenter
.Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, SpecCol - ArrayItem).Value
End With
.Offset(i, 10).Value = myTable.DataBodyRange(rowsArray(k), ArrayItem).Offset(, RemarkCol - ArrayItem).Value
End With
With Range(WriteStartCell.Offset(i, 0), WriteStartCell.Offset(i, 10))
.VerticalAlignment = xlTop
.WrapText = True
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Font.Size = BodyFSize
With .Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End With
i = i + 1
j = j + 1
End If
Next
j = j + 2
NextWriteRow = NextWriteRow + j
i = i + 2
j = 0
Next
'This is the autofit that won't work for some reason
Cells.Rows.Autofit
Debug.Print "Works"
End Sub
'---
Sub AutofitRowHeight()
Dim sheetnames() As String
ReDim sheetnames(0 To 17)
sheetnames(0) = "SF-ALL-I"
sheetnames(1) = "SF-ALL-E"
sheetnames(2) = "SF-H-I"
sheetnames(3) = "SF-H-E"
sheetnames(4) = "SF-CUP-I"
sheetnames(5) = "SF-CUP-E"
sheetnames(6) = "SF-GB-I"
sheetnames(7) = "SF-GB-E"
sheetnames(8) = "LM-ALL-I"
sheetnames(9) = "LM-ALL-E"
sheetnames(10) = "LM-H-I"
sheetnames(11) = "LM-H-E"
sheetnames(12) = "LM-CC-I"
sheetnames(13) = "LM-CC-E"
sheetnames(14) = "LM-SCC-I"
sheetnames(15) = "LM-SCC-E"
sheetnames(16) = "LM-GB-I"
sheetnames(17) = "LM-GB-E"
Dim i As Variant
For i = LBound(sheetnames) To UBound(sheetnames)
Sheets(sheetnames(i)).Activate
Cells.Rows.AutoFit
Next
Sheets("Database").Activate
Cells(1, 1).Select
End Sub
Hi I have created a workbook that uses formula to populate lists, one of which uses VBA to print labels.
My problem is the VBA sees the cell formula in blank cells and wants to print blank tags. How can I change it to see text only?
As I said, I need to edit my VBA to ignore formula and read only the resulting text.
VBA is below.
Sub Print_Labels()
Application.ScreenUpdating = False
Col_Width_1 = Range("Column_Width_1")
Col_Width_2 = Range("Column_Width_2")
Col_Width_3 = Range("Column_Width_3")
Col_Width_4 = Range("Column_Width_4")
Row_Height_1 = Range("Row_Height_1")
Row_Height_2 = Range("Row_Height_2")
Row_Height_3 = Range("Row_Height_3")
Row_Height_4 = Range("Row_Height_4")
Sheets("Equipment_List").Select
Num_Equip = Range("A1").CurrentRegion.Rows.Count
Start_Row = Range("Title_Label_Start_Row")
First_Page_YN = True
Names.Add "Equipment_List", "=" + Range("A1").Resize(Num_Equip).Address
Sheets("Labels").Select
' Set page setup
' Set column widths
For Count_Label_Columns = 1 To Num_Label_Columns
Range("A1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_1
Range("B1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_2
Range("C1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_3
Range("D1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_4
Next Count_Label_Columns
' Set row heights
For Count_Label_Rows = 1 To Num_Label_Rows
Range("A1").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_1
Range("A2").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_2
Range("A3").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_3
Range("A4").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_4
Next Count_Label_Rows
' Work out the first label row to be printed
If Start_Row > 10 Then Start_Row = 10
Count_Label_Rows = Start_Row
' Labels always start printing in the first column
Count_Label_Columns = 0
For Count_Equip = 1 To Num_Equip
' Start of new page of labels, so completely clear sheet
If First_Page_YN = True Then
Cells.Clear
First_Page_YN = False
End If
Count_Label_Columns = Count_Label_Columns + 1
If Count_Label_Columns > Num_Label_Columns Then
Count_Label_Columns = 1
Count_Label_Rows = Count_Label_Rows + 1
End If
If Count_Label_Rows > Num_Label_Rows Then
Count_Label_Rows = 1
Count_Label_Columns = 0
End If
If Count_Label_Rows = 1 And Count_Label_Columns = 0 Then
' Start of new page, so print full sheet
If Range("Title_Print_Preview") = "Print" Then
ActiveSheet.PrintOut
Else
ActiveSheet.PrintPreview
End If
Cells.Clear
Count_Label_Columns = 1
End If
Range("Title_Label_Format").Copy
Range("Labels_Top").Offset(((Count_Label_Rows - 1) * 4),
((Count_Label_Columns - 1) * 4) + 1).PasteSpecial
Range("Labels_Top").Offset(((Count_Label_Rows - 1) * 4) + 2,
((Count_Label_Columns - 1) * 4) + 2) = _
Range("Equipment_List").Offset(Count_Equip - 1).Resize(1, 1)
' Enter the sequence number of the equipment
Range("Labels_Top").Offset(((Count_Label_Rows - 1) * 4),
((Count_Label_Columns - 1) * 4) + 3) = Count_Equip
Next Count_Equip
' Print or Preview the last sheet
If Range("Title_Print_Preview") = "Print" Then
ActiveSheet.PrintOut
Else
ActiveSheet.PrintPreview
End If
Application.ScreenUpdating = True
End Sub
-------------------------------------------------------------------------------
I have the follow script to put a list of people with there know skills in an array and then match the first match with a customer with the same skill. Every time it runs the results are the same. I would like to have it be a random order of the array, but keeping the two columns in the array together. How can I shuffle(rearrange) the array that keeps the rows in the array the same? Or would it be better to erase the array, randomly sort the columns and set the array back up?
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
p = 0
o = 0
For i = 2 To 920
If Cells(i, 12).Value <> Cells(i - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(i, 12).Value
arOne(p, 1) = Cells(i, 13).Value
o = 2
Else
arOne(p, o) = Cells(i, 13).Value
o = o + 1
End If
Next
For i = 2 To 612
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & i), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(i, 2).Value Then
Cells(i, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
GoTo NextIR
End If
Next j
End If
End If
Next o
NextIR:
Next i
End Sub
Multiple loops and multiple access to range objects makes your code very, very slow (I don't know if performance is important).
I would read all necessary data to arrays and use filter and rnd to get a random person with the relevant skill:
Option Explicit
Sub PeopleBusiness()
Dim People, Customers, FilterArray
Dim I As Long, Idx As Long
People = Application.Transpose([L2:L920 & "|" & M2:M8])
Customers = Range("A2:C612").Value2
For I = 1 To UBound(Customers, 1)
FilterArray = Filter(People, Customers(I, 2))
If UBound(FilterArray) > -1 Then
Idx = Round(Rnd() * UBound(FilterArray), 0)
Customers(I, 3) = Left(FilterArray(Idx), InStr(1, FilterArray(Idx), "|") - 1)
End If
Next I
Range("A2:C612").Value = Customers
End Sub
I was able to get done what I needed by erasing the array and redimming it after sorting the data based on a rand() number in the table. It takes about 15 minutes to run 7000 assignment but it is a lot better than 7+ hours it takes to do manually.
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
Application.Calculation = xlAutomatic
StartTime = Timer
NextIR:
ReDim arOne(1000, 15)
p = 0
o = 0
QAlr = Sheets("Sheet1").Range("L" & Rows.Count).End(xlUp).Row
For I = 2 To QAlr
If Cells(I, 12).Value <> Cells(I - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(I, 12).Value
arOne(p, 1) = Cells(I, 13).Value
o = 2
Else
arOne(p, o) = Cells(I, 13).Value
o = o + 1
End If
Next
AQAlr = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
AgtLr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For I = AQAlr + 1 To AgtLr
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & I), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(I, 2).Value Then
Cells(I, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
Erase arOne()
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Random '#]]"), SortOn:=xlSortOnValues, Order:= _
xlDescending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
GoTo NextIR
End If
Next j
End If
End If
Next o
Next I
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Assignments completed in " & MinutesElapsed & " minutes", vbInformation
End Sub
Not entirely sure I got your set-up right but you can try this:
Option Explicit
Sub Assign()
Randomize
Range("C2", Range("C" & Rows.Count).End(xlUp)).ClearContents
Dim R1 As Range: Set R1 = Range("L2:M920") 'People skill table
Dim R2 As Range: Set R2 = Range("A2:B612") 'Cusotmers skill talbe
Dim D0 As Object: Set D0 = CreateObject("scripting.dictionary")
Dim i As Integer, j As Integer, Rand as Integer
For i = 1 To R2.Rows.Count
Rand = Int(R1.Rows.Count * Rnd + 1)
For j = 1 To R1.Rows.Count
If R1.Cells(Rand, 2) = R2(i, 2) And Not D0.exists(Rand) Then
R2.Cells(i, 2).Offset(0, 1) = R1(Rand, 1)
D0.Add Rand, Rand
Exit For
End If
Rand = (Rand Mod R1.Rows.Count) + 1
Next j
Next i
End Sub
The idea is to check the people skill list starting from a random point and making sure a key is not used twice.
EDIT:
According to your comment I assume a "people / skill" can then be assigned more than once as there are 7000+ customers ?
Code below randomly assign with a fairly good distribution 1500 peoples to 7000 customers in +/- 1 second.
Have a try and see if you can adapt it to your project.
Option Explicit
Sub Assign()
Application.ScreenUpdating = False
Dim Start: Start = Timer
Randomize
Range("C2:C99999").ClearContents
Dim D1 As Object
Dim R1 As Range: Set R1 = Range("L2", Range("M" & Rows.Count).End(xlUp))
Dim R2 As Range: Set R2 = Range("A2", Range("B" & Rows.Count).End(xlUp))
Dim T1: T1 = R1
Dim T2: T2 = R2
Dim T3()
Dim a As Integer: a = 1
Dim i As Integer, j As Integer, k As Integer, Rnd_Val As Integer, j_loop As Integer
For i = 1 To (Int(R2.Rows.Count / R1.Rows.Count) + 1)
Set D1 = CreateObject("scripting.dictionary")
For j = (R1.Rows.Count * i - R1.Rows.Count + 1) To R1.Rows.Count * i
ReDim Preserve T3(1 To j)
Rnd_Val = Int(Rnd * R1.Rows.Count + 1)
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) And Not D1.exists(Rnd_Val) And T3(j) = "" Then
T3(j) = T1(Rnd_Val, 1)
D1.Add Rnd_Val, Rnd_Val
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
If T3(j) = "" Then
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) Then
T3(j) = T1(Rnd_Val, 1)
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
End If
a = a + 1
If a > R2.Rows.Count Then GoTo EndLoop
Next j
Set D1 = Nothing
Next i
EndLoop:
Range("C2").Resize(UBound(T3), 1) = Application.Transpose(T3)
Debug.Print Timer - Start
Application.ScreenUpdating = True
End Sub
I did a vb code which is reading multiple text files from a folder and then parsing specific data from it. In the code I have hard coded a folderpath strPath = "C:\Users\smim\Desktop\Mim\Excel\". Now I would like to be able to choose the folder and files manually instead of hard coding the folder path. Here is my code :
Sub Parse()
Dim ws As Worksheet
Dim MyData As String, strData() As String
Dim WriteToRow As Long, i As Long
Dim strCurrentTxtFile As String
Dim count As Variant, yellow As Variant, red As Variant,
Dim YellowC As Variant,RedC As Variant, filecounter As Variant
Dim strPath As String
Application.ScreenUpdating = False
count = 0
red = 0
yellow = 0
YellowC = 0
RedC = 0
strPath = "C:\Users\smim\Desktop\Mim\Excel\"
'Set Book3 = Sheets("Sheet1")
Set ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
MsgBox ("Started")
'~~> Start from Row 1
'WriteToRow = 1
Cells(3, 1) = "Error"
Cells(3, 1).Interior.ColorIndex = 3
Cells(3, 2) = "Warnings"
Cells(3, 2).Interior.ColorIndex = 6
Cells(1, 3) = "Error"
Cells(1, 3).Interior.ColorIndex = 3
Cells(2, 3) = "Warnings"
Cells(2, 3).Interior.ColorIndex = 6
strCurrentTxtFile = Dir(strPath & "test_*.txt")
' MsgBox (strCurrentTxtFile)
'~~> Looping through all text files in a folder
Do While strCurrentTxtFile <> ""
Dim list() As String
'~~> Open the file in 1 go to read it into an array
Open strPath & strCurrentTxtFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbLf)
LineCount = UBound(strData)
' MsgBox (LineCount)
'Assigning length of the list array
ReDim Preserve list(LineCount + 1)
For x = 0 To (LineCount - 1)
'For x = LBound(strData) To UBound(strData)
'Parsing each line to get the result only ( after = sign)
s = Split(strData(x), "=")
b = UBound(s)
'MsgBox (s(1))
'Assigning Values to the list array
list(x) = s(1)
Next
'MsgBox ("This is list" & list(2))
'Active Cell 2
Range("A2").Activate
'Get row number
dblRowNo = ActiveCell.Row
'Get col number
dblColNo = ActiveCell.Column
'MsgBox (dblColNo)
' ReDim Preserve list(LineCount)
For i = 0 To (LineCount - 1)
Cells(3, 3 + i + 1).Value = i
'Looping and assigning Values to the Cell
'For i = LBound(strData) To UBound(strData)
tempParsing = Split(list(i), ":")
' MsgBox (tempParsing(0))
If tempParsing(0) > 0 And tempParsing(0) < 10 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 6
yellow = yellow + 1
ElseIf tempParsing(0) >= 10 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 3
red = red + 1
ElseIf tempParsing(0) = 0 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 0
End If
'Looping and assigning Values to the Cell
' For i = LBound(strData) To UBound(strData)
Cells(dblRowNo + count + 2, dblColNo + 1) = yellow
Cells(dblRowNo + count + 2, dblColNo) = red
Cells(dblRowNo + count + 2, dblColNo + i + 3).Value = list(i)
Next
Cells(3 + count + 1, 3).Value = count
count = count + 1
yellow = 0
red = 0
strCurrentTxtFile = Dir
Loop
For t = 4 To 175
If Cells(t, 1).Value > 0 Then
Cells(t, 1).Interior.ColorIndex = 3
End If
If Cells(t, 2).Value > 0 Then
Cells(t, 2).Interior.ColorIndex = 6
End If
Next
'Cells(9, 1) = "linecount = "
'Cells(9, 2) = LineCount
MsgBox "Done"
For f = 4 To 175
If Cells(f, 4).Interior.ColorIndex = 6 Then
YellowC = YellowC + 1
ElseIf Cells(f, 4).Interior.ColorIndex = 3 Then
RedC = RedC + 1
End If
Next
For g = 4 To 175
If Cells(g, 7).Interior.ColorIndex = 6 Then
YellowC = YellowC + 1
ElseIf Cells(g, 7).Interior.ColorIndex = 3 Then
RedC = RedC + 1
End If
Next
For u = 0 To (LineCount - 1)
Cells(dblRowNo, dblColNo + u + 3) = YellowC
Cells(1, dblColNo + u + 3) = RedC
Next
YellowC = 0
RedC = 0
Application.ScreenUpdating = True
End Sub
The problem with the error bars seems to be resolved, but now I am gettng a error 5. The error line is:
ActiveChart.SeriesCollection(1).ApplyDataLabels AutoText:=False, LegendKey:=False, ShowSeriesName:=False, ShowCategoryName:=False, ShowValue:=True, _
ShowPercentage:=False, ShowBubbleSize:=False
'resize chart
WS.ChartObjects(1).Width = 500
WS.ChartObjects(1).Height = chartmultipl * (rowcnt - 1 - minscale)
WS.ChartObjects(1).Left = chartleftpos
WS.ChartObjects(1).Top = 70
'Rescale values to positions in chart so that labels can be succesfully moved
minchar = ActiveChart.Axes(xlCategory).MinimumScale
maxchar = ActiveChart.Axes(xlCategory).MaximumScale
midchar = (maxchar + minchar) / 2
'datalabels
ActiveChart.SeriesCollection(1).ApplyDataLabels AutoText:=False, LegendKey:=False, ShowSeriesName:=False, ShowCategoryName:=False, ShowValue:=True, _
ShowPercentage:=False, ShowBubbleSize:=False
For i = 1 To rowcnt - 1
If WS.Cells(i + 1, labelcol) <> "" Then
With ActiveChart.SeriesCollection(1).Points(i).DataLabel
.Characters.Text = Left(WS.Cells(i + 1, labelcol).Value, 28)
.AutoScaleFont = False
With .Characters(Start:=1, Length:=100).Font
.Name = "Arial"
If WS.Cells(i + 1, labelcol).Font.Italic = True Then
.FontStyle = "Italic"
ElseIf WS.Cells(i + 1, labelcol).Font.Bold = True Or Not ptype Then
.FontStyle = "Bold"
Else
.FontStyle = "Normal"
End If
.Size = labelsize
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
'move labels wherever there is enough space to display them or to the beginning of the graph
If ptype Then
textsize = Application.WorksheetFunction.Min(Len(WS.Cells(i + 1, labelcol).Value), 28)
If WS.Cells(i + 1, int1).Value <= midchar Then
.Left = 15 + Round(ActiveChart.PlotArea.Width * (WS.Cells(i + 1, 6).Value - minchar) / (maxchar - minchar))
Else
.Left = -textsize * 3 + Round(ActiveChart.PlotArea.Width * (WS.Cells(i + 1, 5).Value - minchar) / (maxchar - minchar))
End If
Else
.Left = 20
End If
End With
End If
Next i
'if it's an outcome graph use set square sizes, if a final MA graph use study weights
If Not ptype Then
For i = 1 To resultcount
With ActiveChart.SeriesCollection(1).Points(i)
.MarkerSize = Round(sqsize(i), 0)
End With
Next i
End If
'send chart to back for future merging
WS.ChartObjects(1).SendToBack
'ActiveChart.ChartArea.Select
'Selection.ShapeRange.ZOrder msoSendToBack
'deselect graph so that I can add the rest of the shapes but first save things that are needed
minsc = ActiveChart.Axes(xlCategory).MinimumScale
maxsc = ActiveChart.Axes(xlCategory).MaximumScale
WS.Range("A1").Select
'if it is the final scatterplot add the diamonds
If Not ptype Then
Dim plarealeft, plarearight As Double
Dim dheight, incrh As Double
Dim origleft, origlength, transleft As Double
Dim diampos, diamlength As Double
Dim grtop As Double
'left and right edge of plot area in pixels
plarealeft = 371
plarearight = 827
'diamond statistics
dheight = 10
'vertical alignment of diamonds - increment from one to another
incrh = WS.ChartObjects(1).Height / ((rowcnt - 1) - minscale + 2)
'top of the graph
grtop = WS.ChartObjects(1).Top
'get all info in tables so that I can use in loops
mu(1) = fe_mu
mu(2) = dl_mu
mu(3) = ml_mu
mu(4) = pl_mu
mu(5) = T_mu
mvar(1) = fe_var
mvar(2) = dl_var
mvar(3) = ml_var
mvar(4) = pl_var
mvar(5) = T_var
For i = 1 To 4
tmargin(i) = 1.96
Next i
tmargin(5) = Excel.WorksheetFunction.TInv(0.05, resultcount - 1)
tlabel(1) = "FE"
tlabel(2) = "DL"
tlabel(3) = "ML"
tlabel(4) = "PL"
tlabel(5) = "T"
'go through all 5 diamonds
For i = 1 To 5
'original length and far left position
origleft = mu(i) - tmargin(i) * (mvar(i) ^ (1 / 2))
origlength = 2 * tmargin(i) * (mvar(i) ^ (1 / 2))
'transform to [0,1] scale
transleft = (origleft - minsc) / (maxsc - minsc)
'transform to points
diampos = plarealeft + (plarearight - plarealeft) * transleft + 1
diamlength = (plarearight - plarealeft) * origlength / (maxsc - minsc)
ActiveSheet.Shapes.AddShape(msoShapeDiamond, diampos, grtop + (rowcnt - 1.5 + i + 1) * incrh - dheight / 2, diamlength, dheight).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 0)
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, diampos + diamlength + 10, grtop + (rowcnt - 1.5 + i + 1) * incrh - dheight / 2, 20, 12).Select
Selection.Characters.Text = tlabel(i)
With Selection.ShapeRange
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
End With
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 9
End With
Next i
End If
'add text files with study information
If ptype Then
tboxend = rowcnt * 10
tboxstep = (tboxend - 80) / (rowcnt - 2)
For i = 2 To rowcnt
If (WS.Cells(i, 1).Value <> "" And WS.Cells(i - 1, 1).Value = "") Or i = 2 Then
'find how many outcomes there are in each study to better align the text boxes
j = i
Do
j = j + 1
Loop Until WS.Cells(j, 1).Value = ""
cntr = j - i
'create textbox
tboxpos = tboxend - (i - 2) * tboxstep - (cntr - 1) * tboxstep / 2
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 500, tboxpos, 60, 25).Select
Selection.Characters.Text = WS.Cells(i, 1).Value
With Selection.ShapeRange
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
End With
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End If
Next i
End If
'create a list with all the shapes that need to be selected and group them
j = 0
For Each Sh In WS.Shapes
If Not Left(Sh.Name, 7) = "Comment" Then
j = j + 1
ReDim Preserve sharray(j)
sharray(j) = Sh.Name
End If
Next Sh
WS.Shapes.Range(sharray).Group
'deselect shape
WS.Range("A1").Select
Application.ScreenUpdating = True
End Sub
First thing to do, to help track down the error is to define all your variables properly.
Example: your first line
Dim rowcnt, textsize, cntr, labeltop As Integer
is actually the same as this:
Dim rowcnt as Variant
Dim textsize as Variant
dim cntr as Variant
dim labeltop As Integer
doing this may bring up other errors that can help you track down what is causing the line to fail
Declare Option Explicit at the top of your code, it will help you write better code by forcing you to declare all variables and help you identify bugs more easily.
This is probably causing your Invalid Call or Argument error:
'get the last row of data
rowcnt = LASTINCOLUMN2(6, k)
Unless you have a custom function called LASTINCOLUMN2 that you didn't post?
To get the last row use:
rowcnt = WS.Range("B" & Rows.Count).End(xlUp).Row
Declare rowcnt as Long not an integer.
You need to define:
ptype
resultcount
vareffects
Edit: I am still running through your code and identifying many unidentified subs/functions. Is there a second part to the code?