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?
Related
with the given code I am trying hard incorporate the Filldown approach until the last row but at present whatever I do only fills row number 1:
Sub FillDownApproach()
Dim destinationWs As Worksheet
Dim destinationLastRow As Long
Set destinationWs = ThisWorkbook.Worksheets("Main Board")
destinationLastRow = destinationWs.Range("A" & Rows.Count).End(xlUp).Row
RetVal = destinationWs.Evaluate("INDEX('MyData'!$E:$E,MATCH(1,($A2='MyData'!$B:$B)*(""MyItem""='MyData'!$D:$D),0))")
destinationWs.Range("C2").Value = RetVal
destinationWs.Range("C3: " & "C" & destinationLastRow).FillDown
End Sub
Any suggestion that could point towards the right direction.
Thanks
You cannot do what you want without looping. And Looping ranges is slow.
Instead load Variant arrays and loop them.
Sub FillDownApproach()
Dim destinationWs As Worksheet
Set destinationWs = ThisWorkbook.Worksheets("Main Board")
Dim destinationLastRow As Long
destinationLastRow = destinationWs.Range("A" & Rows.Count).End(xlUp).Row
Dim lkpArr As Variant
lkpArr = destinationWs.Range("A2:A" & destinationLastRow).Value
With Worksheets("MyData")
Dim retval As Variant
retval = Intersect(.Range("E:E"), .UsedRange)
Dim mtch As Variant
mtch = Intersect(.Range("B:D"), .UsedRange)
End With
Dim outArr As Variant
ReDim outArr(1 To UBound(lkpArr, 1), 1 To 1)
Dim i As Long
For i = 1 To UBound(lkpArr, 1)
Dim j As Long
For j = 1 To UBound(retval, 1)
If mtch(j, 3) = "MyItem" Then
If mtch(j, 1) = lkpArr(i, 1) Then
outArr(i, 1) = retval(j, 1)
Exit For
End If
End If
Next j
Next i
destinationWs.Range("C2").Resize(UBound(outArr, 1), 1).Value = outArr
End Sub
I am having a hard time getting the below logic to work. The issue seems to be where the Year function is placed. It seems to be skipping over the logic completely, yet i'm not sure how to encorporate the year function without breaking the with loop.
Sub BlankLine()
Dim Col_year As Variant
Dim Col_st As Variant
Dim Col_btc As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim ws As Worksheet
Dim wb As Workbook
Dim state_ar() As Variant
Col_year = "E"
Col_st = "C"
Col_btc = "D"
StartRow = 1
BlankRows = 1
Set wb = ThisWorkbook
Set ws = wb.Worksheets("LU_WK_BENE_AMT")
LastRow = ws.Cells(Rows.Count, Col_year).End(xlUp).Row
Application.ScreenUpdating = False
state_ar = Array("02", "03")
For Each State In state_ar
With ws
For R = LastRow To StartRow + 1 Step -1
If Year(.Cells(R, Col_year).Value) = 2020 And .Cells(R, Col_st) = i Then
.Cells(R + 1, Col_year).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col_year).Value = 2021
.Cells(R + 1, Col_st).Value = .Cells(R, Col_st).Value
.Cells(R + 1, Col_btc).Value = .Cells(R, Col_btc).Value
End If
Next R
End With
Next
Application.ScreenUpdating = True
End Sub
I am trying to build a macro that goes through my data set and checks if there's any text in column W, if it does I would like the macro to duplicate the row beneath it, then move the values from Columns X and W to U and Q respectively.
My code at the moment is only trying to get the duplicate part down but its not working and I'm kind of stuck, could you have a look at it and help out?
Dim lastRow2 as Long
Dim cel as Range, srchRng as Range
lastRow2 = Worksheets("UPLOAD COPY").Cells(Rows.Count, 23).End(xlUp).Row
Set srchRng = Range("W2: W" & lastRow2)
For Each cel In srchRng
If InStr(1, cel.Value, "*") > 0 Then
cel.Offset(1).Insert
cel.EntireRow.Copy cel.Offset(1)
Set cel = cel.Offset(2)
End If
Next cel
Create Duplicate Rows
Option Explicit
Sub createDuplicateRows()
Const wsName As String = "UPLOAD COPY"
Const FirstRow As Long = 2
Const Col As Variant = "W" ' or 23
Dim OldCols As Variant: OldCols = Array("W", "X") ' or 23, 24
Dim NewCols As Variant: NewCols = Array("Q", "U") ' or 17, 21
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim CurrentRow As Long: CurrentRow = FirstRow
Dim j As Long
Do
If ws.Cells(CurrentRow, Col).Value <> "" Then GoSub insertRow
CurrentRow = CurrentRow + 1
Loop Until CurrentRow > LastRow
Exit Sub
insertRow:
ws.Rows(CurrentRow + 1).EntireRow.Insert Shift:=xlDown
ws.Rows(CurrentRow).EntireRow.Copy ws.Rows(CurrentRow + 1)
CurrentRow = CurrentRow + 1
GoSub changeValues
LastRow = LastRow + 1
Return
changeValues:
For j = 0 To UBound(OldCols)
ws.Cells(CurrentRow, NewCols(j)).Value _
= ws.Cells(CurrentRow, OldCols(j)).Value
ws.Cells(CurrentRow, OldCols(j)).ClearContents
Next j
Return
End Sub
EDIT:
You can write the 'delete part' in a separate subroutine. Then you can do what I suggested in the comments. Sorry, I didn't realize that previously it would copy the already cleared (empty) values.
Option Explicit
Sub createDuplicateRows()
Const wsName As String = "UPLOAD COPY"
Const FirstRow As Long = 2
Const Col As Variant = "W" ' or 23
Dim OldCols As Variant: OldCols = Array("W", "X", "X") ' or 23, 24, 24
Dim NewCols As Variant: NewCols = Array("Q", "U", "Y") ' or 17, 21, 25
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim CurrentRow As Long: CurrentRow = FirstRow
Dim j As Long
Do
If ws.Cells(CurrentRow, Col).Value <> "" Then GoSub insertRow
CurrentRow = CurrentRow + 1
Loop Until CurrentRow > LastRow
Exit Sub
insertRow:
ws.Rows(CurrentRow + 1).EntireRow.Insert Shift:=xlDown
ws.Rows(CurrentRow).EntireRow.Copy ws.Rows(CurrentRow + 1)
CurrentRow = CurrentRow + 1
GoSub changeValues
LastRow = LastRow + 1
Return
changeValues:
For j = 0 To UBound(OldCols)
ws.Cells(CurrentRow, NewCols(j)).Value _
= ws.Cells(CurrentRow, OldCols(j)).Value
Next j
GoSub deleteValues
Return
deleteValues:
For j = 0 To UBound(OldCols)
ws.Cells(CurrentRow, OldCols(j)).ClearContents
Next j
Return
End Sub
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
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