I have a code, written for me by #Jon49 that i adapted to suit my purposes :
The problem i have with this code is that it works for some of my files but produce an error 9 subscript out of range on others. essentially i have a loop that opens every file in a folder in turn performs the foloowing code. saves it then closes it before opening another one. The format of all the files is the same. so what is producing the error??
When the error happens and i debug it it tends to show the cause some where here :
sData(j, 7) = vData(1, j + 10)
sData(j, 8) = vData(i, j + 10)
sData(j, 9) = vData(3, j + 10)
sData(j, 10) = vData(2, j + 10)
SCROLL to BOTTOM for what i think is causing the error
Here is the code:
Range("k1").Select
Dim Parameters As String
Parameters = Range(ActiveCell.End(xlToRight).Offset(0, 0), ActiveCell).Count
Dim i As Long, j As Long, k As Long
Dim rData As Range
Dim sData() As String, sName As String
Dim wks As Worksheet
Dim vData As Variant
Application.EnableEvents = False 'Initialize worksheets
Set wks = ActiveSheet 'Get data
Set rData = wks.UsedRange
vData = rData
ReDim sData(1 To Parameters, 1 To rData.Columns.Count - 10)
rData.Offset(1).Clear
rData.Offset(11).Resize(1).Clear
<---- ??? not sure about importance of the line above because i commented out and the code will still work
For i = 1 To UBound(vData)
For j = 1 To UBound(sData)
For k = 1 To 6
sData(j, k) = vData(i, k)
Next k
sData(j, 7) = vData(1, j + 10)
sData(j, 8) = vData(i, j + 10)
sData(j, 9) = vData(3, j + 10)
sData(j, 10) = vData(2, j + 10)
Next j 'Print transposed data
wks.Range("A" & Application.Rows.Count).End(xlUp) _
.Offset(1).Resize(UBound(sData), UBound(sData, 2)) = sData
Next i
Application.EnableEvents = True
Range("K1").Select
Range(ActiveCell.End(xlToRight).Offset(0, 0), ActiveCell).Delete
Rows("2:" & Parameters + 1).Delete
One thing that i noticed is the files that the error seems to be produced on
has few parameters ( the two files ive noticed it erroring so far have 9 [will debug to sData(j, 10) = vData(2, j + 10)] and 7 [sData(j, 8) = vData(i, j + 10)]parameters each ) the others it is okay with so far each have more than 10 parameters . parameters being CH4, NO, NO2 etc
You're trying to access a value which doesn't exist in your sData or vData array. One or both of them have fewer "rows" or "columns" than you think. Try adding:
Msgbox "sData: #rows=" & ubound(sData,1) & " #cols=" & _
ubound(sData,2) & vbcrlf &
"vData #rows=" & ubound(vData,1) & " #cols=" & ubound(vData,2)
Immediately after
ReDim sData(1 To Parameters, 1 To rData.Columns.Count - 10)
See what values you get.
Related
I have a script I use that goes down a column in a second worksheet and pulls only the managers (their employees data) that I specify.
It takes about .8-.9 seconds for each file to form from both arrays (one for storing and the second for a faster printing to a new wb)
Are there any revisions you would make in order to drastically speed it up? I know that the majority of the time spent is saving/password protecting.
script:
Option Explicit
Sub HR_Assessment()
Dim j As Long, k As Long, x As Long ' counters
Dim varArray() As Variant
Dim varArray2() As Variant
ReDim varArray(1 To 75, 1 To 1)
Dim strManager As String
Dim BASEPATH As String, strNewPath As String, strFileName As String
Dim Wb As Workbook
Dim mgrRow As Long ' counter
Dim colManager As Long ' the column manager appears in
colManager = 1
BASEPATH = "M:\Raw Reports\HR\"
Call Ludicrous(True) - this is just a separate module that turns off calculations/screen updating/etc....
For mgrRow = 2 To ThisWorkbook.Worksheets("Mgrs").UsedRange.Rows.Count
If ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 1) <> "" Then
strManager = ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 1)
With ThisWorkbook.Worksheets("Sheet1")
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
x = 1
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(1, k)
Next
For j = 1 To .UsedRange.Rows.Count + 1
If strManager = .Cells(j, colManager) Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(j, k)
strManager = .Cells(j, colManager)
Next
End If
Next
End With
strNewPath = BASEPATH & "11.01.18" & "\"
If Len(Dir(strNewPath, vbDirectory)) = 0 Then
MkDir strNewPath
End If
' Path is now "constant path"
strFileName = strManager & " - " & "HR_Assessment" & ".xlsx"
ReDim varArray2(1 To UBound(varArray, 2), 1 To UBound(varArray, 1))
Set Wb = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)
With Wb
With .Worksheets("Sheet1")
For j = 1 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
varArray2(j, k) = varArray(k, j)
Next
Next
.Range(.Cells(1, 1), .Cells(UBound(varArray, 2), UBound(varArray, 1))) = varArray2
.Range("A:B").Columns.AutoFit
End With
.SaveAs strNewPath & strFileName, Password:="password", FileFormat:=51
.Saved = True
.Close
End With
Set Wb = Nothing
End If
Next
Call Ludicrous(False)
End Sub
can someone please look into my code and say me where is the mistake cause I got a type mismatch error message ? With this code I would like to delete all rows who which contain "0" in the respective cells.
I got the error message for the line where is standing: sn = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "|")), [transpose(row(1:8))])
Also I had to declare the variable "c00" and I choosed "c00 As Variant". I don't know if it its correct. I would appreciate someone helping me to solve the problem.
Dim sn As Variant, c00 As Variant
sn = Sheets(1).UsedRange
For j = 1 To UBound(sn)
If sn(j, 4) & sn(j, 5) & sn(j, 6) & sn(j, 7) & sn(j, 8) & sn(j, 9) = "000000" Then c00 = c00 & "|" & j
Next
If c00 <> "" Then
sn = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "|")), [transpose(row(1:8))])
Sheets(1).UsedRange.ClearContents
Sheets(1).Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End If
Original Code
Dim LR%
LR = Cells(Rows.Count, 3).End(xlUp).Row
Set Myrange = Range("D2:AO" & LR).SpecialCells(xlCellTypeBlanks) 'nur Leerzellen
Myrange.Formula = "0"
ActiveSheet.UsedRange
Set r = ActiveSheet.UsedRange
lastrow3 = r.Rows.Count + r.Row - 1
For j = lastrow3 To 1 Step -1
If (Cells(j, 4) = 0 And Cells(j, 5) = 0 And Cells(j, 6) = 0 And Cells(j, 7) = 0 And Cells(j, 8) = 0 And Cells(j, 9) = 0) Then
Rows(j).Delete
End If
Next j
Image w/ Error
Edit: the error was from attempting to use Application.Index on an array larger than the function size limit. Redirect to here for Q&A an on alternative option to Application.Index.
I'll break down my analysis of your code:
Application.Index(Array, Row_Number, Column_Number)
The code you currently have:
sn = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "|")), [transpose(row(1:8))])
is saying that the parameters are:
Array: sn
Row_Number: Application.Transpose(Split(Mid(c00, 2), "|"))
Column_Number: [transpose(row(1:8))]
The Array section looks fine to me. The Row numbers will, I think(?), be the values for j which you collected in c00 (although the Application.Transpose may not be necessary Correction: it is in this scenario.). I have no idea what is going on with your Column_Number parameter....
Issues:
Application.Index keeps the selected columns/rows. However, your if statement selects the values of j where the rows are entirely 0, so instead of losing them, you would be keeping only those rows.
If your intention is to keep all the columns, you can just input 0 into the Column_Number parameter. Correction: this works when only selecting a single row to keep. If selecting multiple rows, all columns must be listed as well.
Corrected code:
Since this code does delete data, you should save a copy of the data before running this code on it.
Note: c00 can be a Variant; String also works. You will need to also copy over the fillA function, as well.
Dim sn As Variant, c00 As String
sn = Sheets(1).UsedRange
' Changed condition based on your post with previous code. (And negated)
For j = 1 To UBound(sn)
If Not ((Cells(j, 4) = 0 And Cells(j, 5) = 0 And Cells(j, 6) = 0 And Cells(j, 7) = 0 And Cells(j, 8) = 0 And Cells(j, 9) = 0)) Then c00 = c00 & "|" & j
Next
If c00 <> "" Then
' Corrected inputs for Application.Index, Added helper function "fillA".
sn = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "|")), fillA(1, UBound(sn, 2) - LBound(sn, 2) + 1))
Sheets(1).UsedRange.ClearContents
Sheets(1).Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End If
Function fillA(min As Long, max As Long) As Variant
Dim var() As Variant, i As Long
ReDim var(1 To max - min + 1)
For i = min To max
var(i) = i + min - 1
Next i
fillA = var
End Function
Edit:
Realized this did not address your issue. I suspect that the error was from the [transpose(row(1:8))] you were inserting for the Column_Number parameter.
Maybe someone else has a simpler way of doing what I did with the fillA function (what I believe you were attempting).
The VBA code below represents a copy-paste function, filtered by two conditions. The code works and gets the job done, but the problem is the time for it to generate the results - Is there anyone here who knows a more efficient way to write the same code?
Any suggestions are highly appreciated
Private Sub CommandButton3_Click()
Dim c As Range, i As Integer, j As Integer
Range("N6:R50").ClearContents
i = 0
For Each c In Range("B2:B50")
If c = Range("O3").Value And Month(c.Offset(0, -1).Value) = Range("P1").Value Then
Cells(6 + i, 14) = Cells(c.Row, c.Column - 1)
Cells(6 + i, 15) = Cells(c.Row, c.Column + 1)
Cells(6 + i, 16) = Cells(c.Row, c.Column + 2)
Cells(6 + i, 17) = Cells(c.Row, c.Column + 3)
Cells(6 + i, 18) = Cells(c.Row, c.Column + 4)
End If
i = i + 1
Next c
For j = 50 To 6 Step -1
If Cells(j, 15) = "" Then
Range("N" & j, "R" & j).Delete Shift:=xlUp
End If
Next j
End Sub
Try this code (you might change ranges [6] depending on your headers):
Private Sub CommandButton3_Click()
Dim rng As Range
Dim LR As Long
Application.ScreenUpadting = False
LR = Range("N6").CurrentRegion.Rows.Count + 5
Range("N6:R" & LR).ClearContents
LR = Range("A6").CurrentRegion.Rows.Count + 5
Range("A6").CurrentRegion.AutoFilter 1, Range("P1")
Range("A6").CurrentRegion.AutoFilter 2, Range("O3")
If Range("A6").CurrentRegion.SpecialCells(xlCellTypeVisible).Areas.Count > 1 Then
Range("N6:N" & LR).SpecialCells(xlCellTypeVisible).Value = Range("B7:B" & LR).SpecialCells(xlCellTypeVisible).Value
Range("O6:R" & LR).SpecialCells(xlCellTypeVisible).Value = Range("C7:F" & LR).SpecialCells(xlCellTypeVisible).Value
Range("A6").CurrentRegion.AutoFilter
Set rng = Range("N7:R" & LR).SpecialCells(xlCellTypeBlanks)
rng.Rows.Delete Shift:=xlShiftUp
End If
End Sub
Is there someone can help me? I have here code that can duplicate entire row to have 2 rows. After duplicating the first entire row , I want to load string from range "G" into array so that I can get certain string that Am planning to insert in "Thickness" and "width" column for me to use to calculate the "Weight" of the "Profile Type". If you will see I have an array in the code .But that array work differently for me and I had a hard time fulfilling the requirements I need. The array in my code split the String using "X" as delimiter . Once the string was split it will add another cells for each split string. what I want is to do the split not in the column but in the array only so that I can maintain the data in G . I will use the string assigned in the array to get "Thickness and Width" of the profile which is "15 as Thickness and 150 as width". If there's any way to do same thing using other code it will be more helpful to simplify the code.
Reminder that Profiletype string vary its length . Sometimes profile width are 4 digits (LB1000X4500X12/15)
Below are the snapshot of my worksheet for you to identify what the result will be.
Private Sub CommandButton2_Click()
Dim lastrow As Long
Dim i As Integer
Dim icount As Integer
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
'array
'Columns("G:G").NumberFormat = "#"
Dim c As Long, r As Range, v As Variant, d As Variant
For i = 2 To Range("G" & Rows.Count).End(xlUp).Row '2 to 16 cell
'v = Split (range("G" & i), "X")
v = Split((Cells(x, "G") & i), "x")
c = c + UBound(v) + 1
'Next i
For i = 2 To c
If Range("G" & i) <> "" Then
Set r = Range("G" & i)
Dim arr As Variant
arr = Split(r, "X")
Dim j As Long
r = arr(0)
For j = 1 To UBound(arr)
Rows(r.Row + j & ":" & r.Row + j).Insert Shift:=xlDown
r.Offset(j, 0) = arr(j)
r.Offset(j, -1) = r.Offset(0, -1)
r.Offset(j, -2) = r.Offset(0, -2)
Next j
End If
Next i
End If
Next x
End Sub
Does this do what you want? Run in copy of workbook to be safe.
Option explicit
Private Sub CommandButton2_Click()
'Bit redundant, would be better if you fully qualify workbook and worksheet with actual names.'
Dim TargetWorksheet as worksheet
Set TargetWorksheet = Activesheet
With application
.screenupdating = false
.calculation = xlcalculationmanual
End with
With TargetWorksheet
.range("G:G").numberformat = "#"
Dim RowIndex As Long
For RowIndex = .usedrange.rows.countlarge to 1 step -1
If .Cells(RowIndex, "F").value2 = "LB" Then
.Cells(RowIndex, "F").value2 = "ComP"
.Cells(RowIndex + 1, "F").EntireRow.Insert
.Cells(RowIndex, "F").EntireRow.Copy .Cells(RowIndex + 1, "F").EntireRow
Dim SplitProfileType() as string
SplitProfileType = split(mid(.cells(RowIndex+1,"G").value2,3), "X") ' assumes first two characters will always be LB, that it is safe to ignore them and start from third character.'
' Write thickness'
.cells(RowIndex+1, "H").value2 = cdbl(mid(SplitProfileType(ubound(SplitProfileType)),instrrev(SplitProfileType(ubound(SplitProfileType)),"/",-1,vbbinarycompare)+1)
' Write width'
.cells(RowIndex+1, "i").value2 = cdbl(SplitProfileType(1))
' Calculate weight'
.cells(RowIndex+1,"K").value2 = .cells(RowIndex+1,"H").value2 * .cells(RowIndex+1,"I").value2 * .cells(RowIndex+1,"J").value2
End if
' I think because you are inserting a row below (rather than above/before), your RowIndex remains unaffected and no adjustment is needed to code. I could be wrong. I would need to test it to be sure.'
Next rowindex
End with
With application
.screenupdating = true
.calculation = xlcalculationautomatic
End with
End sub
Untested as written on mobile.
It works without duplication.
Sub test2()
Dim vDB, vR()
Dim i As Long, n As Long, k As Long, j As Integer
Dim r As Integer
Dim s As String
vDB = Range("A2", "K" & Range("A" & Rows.Count).End(xlUp).Row)
n = UBound(vDB, 1)
For i = 1 To n
If vDB(i, 6) = "LB" Then
r = 2
Else
r = 1
End If
k = k + r
ReDim Preserve vR(1 To 11, 1 To k)
s = vDB(i, 7)
For j = 1 To 11
If r = 1 Then
vR(j, k) = vDB(i, j)
Else
vR(j, k - 1) = vDB(i, j)
vR(j, k) = vDB(i, j)
End If
Next j
If r = 2 Then
vR(6, k - 1) = "comp"
vR(6, k) = "comp"
vR(8, k) = Split(s, "/")(1)
vR(9, k) = Split(s, "X")(1)
vR(9, k - 1) = vR(9, k - 1) - vR(8, k)
vR(11, k - 1) = (vR(8, k - 1) * vR(9, k - 1) * vR(10, k - 1) * 7.85) / 10 ^ 6 '<~~ k2 weight
vR(11, k) = (vR(8, k) * vR(9, k) * vR(10, k) * 7.85) / 10 ^ 6 '<~~ k3 weight
End If
Next i
Range("f1") = "Type"
Range("a2").Resize(k, 11) = WorksheetFunction.Transpose(vR)
End Sub
It is faster to use an array than to enter it one-to-one in a cell.
Sub test()
Dim vDB, vR()
Dim i As Long, n As Long, k As Long, j As Integer
Dim s As String
vDB = Range("A2", "K" & Range("A" & Rows.Count).End(xlUp).Row)
n = UBound(vDB, 1)
ReDim vR(1 To n * 2, 1 To 11)
For i = 1 To n
k = k + 2
s = vDB(i, 7)
For j = 1 To 11
vR(k - 1, j) = vDB(i, j)
vR(k, j) = vDB(i, j)
Next j
vR(k - 1, 6) = "comp"
vR(k, 6) = "comp"
vR(k, 8) = Split(s, "/")(1)
vR(k, 9) = Split(s, "X")(1)
vR(k, 11) = Empty '<~~ This is calculated Weight value place
Next i
Range("f1") = "Type"
Range("a2").Resize(n * 2, 11) = vR
End Sub
I have tried to build a loop that pulls back certain data when it meets a criteria, then posts the results in my 'Main' sheet.
Unfortunately, when you run the macro it does not pull back all of the data.
However, and this in my opinion is super weird, when you step through it does.
There are no error messages at any point in the code and the code runs the whole way through if you step through/just run the macro.
I have posted my code below:
Sub Loop_Data()
'BR stands for Blank Row
Dim i As Integer, j As Integer, k As Integer, m As Integer, BRMAin As Integer, BRData As Integer, BRPhysNot As Integer, _
SearchRange As Range, strID As String, ExtEnd As Integer, FindRow As Range
BRMAin = Sheets("Main").Cells(Rows.Count, "W").End(xlUp).Row
BRData = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
BRPhysNot = Sheets("PhysNot").Cells(Rows.Count, "A").End(xlUp).Row
Set SearchRange = Sheets("Data").Range("A3:A" & BRData)
Sheets("CoData").Activate
'assign j for number of rows (units) and i to start at 6 (column J) and end at 21
For j = 2 To 48
i = 35
Do Until i = 52
'criteria
If Cells(j, i - 1).Interior.Color <> RGB(51, 51, 51) And Cells(j, i - 1) > 0 And Cells(j, i).Interior.Color = RGB(51, 51, 51) Then
'find duration o
m = 0
Do While Cells(j, i + m).Interior.Color = RGB(51, 51, 51)
m = m + 1
Loop
'check that the flagged is definitely matching criteria
If Cells(j, i + m) = 0 Then
'set string ID as the string of uni & period to find in the helper column of Data sheet
'set k as row which that occurs in
strID = Cells(1, i) & Cells(j, 3)
Set FindRow = SearchRange.Find(strID)
k = FindRow.Row
'Pull back data into main sheet
ThisWorkbook.Sheets("Main").Range("X" & BRMAin + 1) = Sheets("Data").Cells(k, 8)
ThisWorkbook.Sheets("Main").Range("V" & BRMAin + 1) = Sheets("Data").Cells(k, 4)
ThisWorkbook.Sheets("Main").Range("W" & BRMAin + 1) = Sheets("Data").Cells(k, 2)
ThisWorkbook.Sheets("Main").Range("Y" & BRMAin + 1) = m
ThisWorkbook.Sheets("Main").Range("Z" & BRMAin + 1) = Sheets("CoData").Cells(1, i)
End If
End If
i = i + 1
Loop
Next j
End Sub
If a Wait or DoEvents doesn't work, instead of using
Set FindRow = SearchRange.Find(strID)
k = FindRow.Row
You could go with
k = 0
For Each SearchCell In SearchRange
If SearchCell.Text = strID Then k = SearchCell.Row
Next
I'm not 100% sure, but I suspect it has to do with you having multiple sheets, but you aren't being specific about which sheet your ranges are calling to.
I'd add in call out to worksheets for each range and cell. See my code below and let me know if it helps.
Sub Loop_Data() 'loops through CoData Sheet
'BR stands for Blank Row
Dim wb As Workbook, wsData As Worksheet, wsMain As Worksheet, wsPhys As Worksheet, wsCoData As Worksheet
Dim i As Integer, j As Integer, k As Integer, m As Integer, BRMAin As Integer, BRData As Integer, BRPhysNot As Integer
Dim SearchRange As Range, strID As String, ExtEnd As Integer, FindRow As Range
Set wb = ThisWorkbook
Set wsData = wb.Sheets("Data")
Set wsMain = wb.Sheets("Main")
Set wsPhys = wb.Sheets("PhysNot")
Set wsCoData = wb.Sheets("CoData")
BRMAin = wsMain.Cells(Rows.Count, "W").End(xlUp).Row
BRData = wsData.Cells(Rows.Count, "A").End(xlUp).Row
BRPhysNot = wsPhys.Cells(Rows.Count, "A").End(xlUp).Row
Set SearchRange = wsData.Range("A3:A" & BRData)
wsCoData.Activate 'Not necessary to activate a sheet if you need to pull data from it if you link a range to a specific sheet.
'assign j for number of rows (units) and i to start at 6 (column J) and end at 21
For j = 2 To 48
i = 35
Do Until i = 52
'criteria
If wsCoData.Cells(j, i - 1).Interior.Color <> RGB(51, 51, 51) And wsCoData.Cells(j, i - 1) > 0 And wsCoData.Cells(j, i).Interior.Color = RGB(51, 51, 51) Then
'find duration o
m = 0
Do While wsCoData.Cells(j, i + m).Interior.Color = RGB(51, 51, 51)
m = m + 1
Loop
'check that the flagged is definitely matching criteria
If wsCoData.Cells(j, i + m) = 0 Then
'set string ID as the string of uni & period to find in the helper column of Data sheet
'set k as row which that occurs in
strID = wsCoData.Cells(1, i) & wsCoData.Cells(j, 3)
Set FindRow = SearchRange.Find(strID)
k = FindRow.Row
'Pull back data into main sheet
wsMain.Range("X" & BRMAin + 1) = wsData.Cells(k, 8)
wsMain.Range("V" & BRMAin + 1) = wsData.Cells(k, 4)
wsMain.Range("W" & BRMAin + 1) = wsData.Cells(k, 2)
wsMain.Range("Y" & BRMAin + 1) = m
wsMain.Range("Z" & BRMAin + 1) = wsCoData.Cells(1, i)
End If
End If
i = i + 1
Loop
Next j
End Sub
I had to guess on the unlabeled ranges, I just assumed they had to do with the CoData Worksheet since that is what you had active last.
Also, if it helps at all, I noticed you keep calling out to a specific color, you can make that a variable too so you don't have keep typing it so much. See below.
Dim grey as Long
grey = RGB(51, 51, 51)
'Colors are just stored as Longs, in some cases Integer will work, but its mostly safer to just always stick to Long.
'So your grey would equal 3355443: 51 + 51*256 + 51 *256*256
'Example Uses...
If wsCoData.Cells(j, i - 1).Interior.Color <> grey And wsCoData.Cells(j, i - 1) > 0 And wsCoData.Cells(j, i).Interior.Color = grey Then
'...Your code
End if
Do While Cells(j, i + m).Interior.Color = grey
m = m + 1
Loop