In the code below I am getting a runtime error 9: Subscript out of range issue on the below marked line and I'm unable to determine the issue. Any ideas? Any help is greatly appreciated.
Dim wb As Workbook
Dim wsOPS As Worksheet
Set wb = ActiveWorkbook
Dim LastRow As Long
Dim i As Integer
Dim DeletedTL() As Integer
Dim ArraySize As Integer
Set wsOPS = wb.Worksheets.Add(Type:=xlWorksheet)
With wsOPS
.Name = "OPS"
End With
LastRow = Sheets("OPS").UsedRange.Rows.Count
ArraySize = 0
For i = 1 To LastRow
If wsOPS.Range("A" & i).FormatConditions(1).Interior.Color = 0 Then '******Error here******
ArraySize = ArraySize + 1
DeletedTL = wsOPS.Range("C" & i)
End If
Next i
Related
Could you please help on the below code.
I have 2 workbooks and i want to copy the columns from one to another with the matching header.
It shows an error in the following line as (Runtime Error - 1004 --> Application-defined or object Defined error)
tWB.sheets("Main").Range(Cells(TLRow, TCol)) = aWB.sheets(1).Range(Cells(2, SCol), Cells(SLRow, SCol))
Sub Pull ()
Dim FileName() as Variant, nw as integer, i as integer
Dim tWB as Workbook, aWB as Workbook
Dim hcell as Range, Header as Range
Dim SCol as Integer, TCol as Integer, SLRow as Integer, TLRow as Integer, SIndex as Integer,
Dim TIndex as Integer
Set tWB = ThisWorkbook
FileName = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls; *.xlsm),*.xls;*.xlsm", MultiSelect:=True)
nw = UBound(FileName)
Set Header = tWB.sheets("List").Range("A1:A" & tWB.Sheets("List").Range("A" & Rows.Count).End(xlUp).Row)
For i = 1 to nw
Workbooks.Open FileName(i)
Set aWB = ActiveWorkbook
For each hcell in Header
SCol = Application.Match(hcell.value, aWB.Sheets(1).Rows(1),0)
TCol = Application.Match(hcell.Offset(0,1).value, tWB.Sheets("Main").Rows(1),0)
SLRow = aWB.Sheets(1).Cells(aWB.Sheets(1).Rows.Count, "A").End(xlUP).Row
TLRow = tWB.Sheets("Main").Cells(tWB.Sheets(1).Rows.Count, TCol).End(xlUP).Row + 1
SIndex = Split(aWB.sheets(1).cells(1,SCol).Address, "$")(1)
TIndex = Split(tWB.sheets("Main").cells(1,TCol).Address, "$")(1)
tWB.sheets("Main").Range(Cells(TLRow, TCol)) = aWB.sheets(1).Range(Cells(2, SCol), Cells(SLRow, SCol))
Next hcell
Next i
End Sub
Another Method:
Also i have tried to convert the column index number to Letter but am not sure what the error is since the code shows no error but the output is not coming
tWB.Sheets("Main").Range(TIndex & TLRow) = aWB.sheets(1).Range((SIndex & 2), Range(SIndex & SLRow))
I have a function that looks up values across sheets and sums the values. It works so long as the value it is looking up exists across all sheets. If the value does not exist, I'd just like to set the result value to 0.
Sub lookupSum3()
Dim myVlookupResult As Double
Dim myTableArray As Range
Dim myVlookupSum As Double
Dim i As Integer
Dim sheetCount As Integer
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim j As Integer
Dim rowCount As Integer
Set ws1 = Sheets(1)
sheetCount = Sheets.count
rowCount = ws1.Range("A1", ws1.Range("A1").End(xlDown).End(xlDown).End(xlUp)).Rows.count
i = 2
j = 2
Do While j <= rowCount
Do While i <= sheetCount
Set ws = Sheets(i)
Set myTableArray = ws.Range("A:N")
myVlookupResult = Application.vlookup(ws1.Range("A" & j), myTableArray, 5, False)
If IsError(myVlookupResult) = True Then
myVlookupResult = 0
End If
myVlookupSum = myVlookupSum + myVlookupResult
i = i + 1
Loop
i = 2
ws1.Range("B" & j) = myVlookupSum
myVlookupSum = 0
j = j + 1
Loop
MsgBox rowCount
End Sub
The code will show a run-time error '13' for the line myVlookupResult = Application.vlookup(ws1.Range("A" & j), myTableArray, 5, False)
Am I handling the error incorrectly?
I have a code to copy the entire row if column B contains a certain text ("ACK-", but now I need to copy the entire row directly above the one with the certain text ("ACK-". Is this even possible? Any help will be appreciated.
Sub HEA_Filter()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("ack-")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = Sheets("Real Alarms")
For I = 1 To NoRows
Set rngCells = wsSource.Range("B" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
To reference "the row above", you can use the Range.Offset method:
rngCells.Offset(-1).EntireRow.Copy wsDest.Range("A" & DestNoRows)
' ^^^^^^^^^^^^
However, be aware that this raised a runtime error if the range is at row 1, because row 0 does not exist. You might want to add a check for it, for example:
If rngCells.Row > 1 Then rngCells.Offset(-1).EntireRow.Copy ...
Despite reading several threads searching for answers to similar problems I have been unable to debug my code on its own.
I am trying to write a macro that will search all cells between AE and BF for the term "Aeronautics Engineers" and then copy all rows that contain that term to a new sheet. The entire sheet has a total of 99289.
I have tried using the following code without any luck:
Sub MoveAero()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("Aeronautic")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
Thanks for any assistance!
Your problem is in your j loop:
For J = 0 To UBound(strArray)
The UpperBound (Ubound) of array strArray is 0. It's an array with a single element "Aeronautic".
So your loop is looping once and exiting.
Instead try looping through your range:
For Each rngCell in rngCells.Cells
if rngCell.value = "Aeronatic" Then
Found = True
Exit For
End if
Next rngCell
Here we loop through that rngCells range that you just made, cell by cell. Then we test if if the cell has the value you are looking for. If we find it, we set found to true and exit the for loop. You don't have to exit the for loop, but we found what we wanted, so there is no reason not to save some cpu time.
Full code, removed unnecessary variables and moved a little bit around:
Sub MoveAero()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngCell as Range
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
For Each rngCell in rngCells.Cells
if rngCell.value = "Aeronatic" Then
'Moved this logic up from the IF block below
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
Exit For
End if
Next rngCell
Next I
End Sub
Alternatively, you could use that .find method of the range object instead of the second For loop. (Using both for your needs is unnecessary).
Sub MoveAero()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim rngCells As Range
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
'Try to find your search term in the range
If Not (rngCells.Find("Aeronautic") Is Nothing) Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
I would like to convert all my heading of data in Column A
Before:
After:
Is there anyone could help? Thanks so much!
I think this might work for you
Option Explicit
Sub Stackoverflow()
Dim LR As Integer
Dim LC As Integer
Dim LRR As Integer
Dim i As Integer
Dim j As Integer
Dim wss As Object
Dim Sht As Object
Dim wsr As Object
Dim CreateSheetIF As Boolean
Set wss = ActiveWorkbook.ActiveSheet
'Create a sheet for the results
Set Sht = Nothing
On Error Resume Next
Set Sht = ActiveWorkbook.Worksheets("Results")
On Error GoTo 0
If Sht Is Nothing Then
CreateSheetIF = True
Worksheets.Add.Name = "Results"
Else
GoTo Exist
End If
Exist:
Set wsr = ActiveWorkbook.Sheets("Results")
LC = wss.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To LC
LR = wss.Cells(Rows.Count, i).End(xlUp).Row
For j = 1 To LR - 1
LRR = wsr.Cells(Rows.Count, 1).End(xlUp).Row
wsr.Range("A" & LRR + 1) = wss.Cells(1, i)
wsr.Range("B" & LRR + 1) = wss.Cells(j + 1, i)
Next
Next
End Sub
I haven't spend a lot of time doing this. So the code isn't pretty at all.
But it should work.
The Results will be paste on a new sheet called "Results".
Perhaps:
Sub ReOrganize()
Dim MaxCol As Long, Ic As Long, H As Variant
Dim s1 As Worksheet, s2 As Worksheet
Dim MaxRow As Long, K As Long, Jr As Long
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
MaxCol = s1.Cells(1, Columns.Count).End(xlToLeft).Column
For Ic = 1 To MaxCol
H = s1.Cells(1, Ic).Value
MaxRow = s1.Cells(Rows.Count, Ic).End(xlUp).Row
K = 2 * Ic - 1
For Jr = 2 To MaxRow
s2.Cells(Jr - 1, K) = H
s2.Cells(Jr - 1, K + 1) = s1.Cells(Jr, Ic).Value
Next Jr
Next Ic
End Sub