I am faced with this problem: "Identifier too long". What can I do to fix this? I tried using a break "_" . But there will another error: Missing end bracket. Thanks guys.
Sub Netting()
Dim Found As Range
Dim LR As Long
Dim ws As Worksheet
Dim cell As Range
Dim a As Variant, v As Variant, num
Set ws = Sheets("PAYABLES - OUTFLOWS")
Set Found = ws.Rows(1).Find(What:="Invoice Amount", _
LookIn:=xlValues, lookat:=xlWhole)
If Found Is Nothing Then Exit Sub
a = [{"991",1042;"916", 1042;"954",261;"975",3004;"938",726;"901",762;"482",728; _
"482",728;"934",723;"200",724;"201",724;"952",724;"992",3030;"980",3207;"116",626;"939",722;"390",517;"484",548;"339",59;"141",717;"935",59;"994",3370;"140",8408;"950",775;"370", 734 }] 'create 2-d lookup array
LR = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
Found.Offset(0, 1).EntireColumn.Insert
ws.Cells(1, Found.Column + 1).Value = "Netting"
For Each cell In ws.Range(ws.Range("C2"), ws.Cells(LR, 3))
num = CStr(Mid(cell.Value, 3, 3))
v = Application.VLookup(num, a, 2, False)
cell.EntireRow.Cells(Found.Column + 1).Value = IIf(IsError(v), "", v)
Next cell
End Sub
There is a limit on the number of characters per line. You can accomplish this using a much simpler way. Add your data to a spreadsheet ("Sheet1" for example) and in column A and column B.
Sub Assign2DVector()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim a As Variant
a = ws.Range("A1:B20").Value ' set to whatever your actual range is
End Sub
Related
I have a mapping table which I use for matching headers of two separate sheets (Sheet1 and Sheet2).
But what if I have something like this (3 columns in the left part, 2 columns in the right):
Basically I want POS1 2019 EMP1 to be equal to HR DEPARTMAENT Employee1 and so on.
Sheet1,
Sheet2,
Mapping
Any ideas how can I do it?
Thank you in advance! :)
Public Sub test()
Application.ScreenUpdating = False
stack "Sheet1", "Sheet2", "Mapping"
Application.ScreenUpdating = True
End Sub
Public Sub stack(ByVal Sheet1 As String, ByVal Sheet2 As String, ByVal
Mapping As String)
Dim rng As Range, trgtCell As Range, src As Worksheet, trgt As
Worksheet, helper As Worksheet
Dim rngSrc As Range, rngDest As Range
Dim sht As Worksheet
Set src = Worksheets("Sheet1")
Set trgt = Worksheets("Sheet2")
Set helper = Worksheets("Mapping")
With src
For Each rng In Intersect(.Rows(3), .UsedRange).SpecialCells(xlCellTypeConstants)
Dim lkup As Variant
With helper
lkup = Application.VLookup(rng.Value, .Range("D13:E" & .Cells(.Rows.Count, "D").End(xlUp).Row), 2, False)
End With
If Not IsError(lkup) Then
Set trgtCell = trgt.Range("$B$2:$F$7").Find(lkup, LookIn:=xlValues, lookat:=xlWhole)
If Not trgtCell Is Nothing Then
.Range(rng.Offset(1), .Cells(.Rows.Count, rng.Column).End(xlUp)).Copy
With trgt
.Range(Split(trgtCell.Address, "$")(1) & 3).PasteSpecial
End With
End If
End If
Next rng
End With
End Sub
I think dictionaries are the data structure most suited to this type of problem.
Be aware, to use dictionaries in VBA you need to set a reference to the Scripting Runtime library.
Tools->Reference-> Microsoft Scripting Runtime
Here is some code that works on the example you provided:
Public Sub test()
Application.ScreenUpdating = False
stack2 "Sheet1", "Sheet2", "Mapping"
Application.ScreenUpdating = True
End Sub
Public Sub stack(ByVal Sheet1 As String, ByVal Sheet2 As String, ByVal Mapping As String)
Dim rng As Range, src As Worksheet, trgt As Worksheet, helper As Worksheet
Dim sht As Worksheet
Dim dctCol As Dictionary, dctHeader As Dictionary
Dim strKey1 As String, strKey2 As String
Dim strItem As String, col As Integer
Set src = Worksheets(Sheet1)
Set trgt = Worksheets(Sheet2)
Set helper = Worksheets(Mapping)
'build a dictionary to lookup column based on 3 rows of headers
Set dctCol = New Dictionary
arr1 = src.Range("A1:F7") 'arrays are way faster than ranges
For j = 2 To UBound(arr1, 2) 'loop over data from columns B-F
strKey1 = Trim(arr1(1, j)) & "," & Trim(arr1(2, j)) & "," & Trim(arr1(3, j)) 'comma delimit string
dctCol(strKey1) = j 'j is the column number
Next
'build a dictionary to translate 2 headers to 3 headers
Set dctHeader = New Dictionary
arrHelp = helper.Range("A2:E6")
For i = 1 To UBound(arrHelp)
strKey2 = Trim(arrHelp(i, 4)) & "," & Trim(arrHelp(i, 5)) '2 header key
strItem = Trim(arrHelp(i, 1)) & "," & Trim(arrHelp(i, 2)) & "," & Trim(arrHelp(i, 3))
dctHeader(strKey2) = strItem
Next
'update sheet2 with numbers from sheet1
arr2 = trgt.Range("A1:F6")
For j = 2 To 5
'work backwards to find the column
strKey2 = Trim(arr2(1, 2)) & "," & Trim(arr2(2, j)) '2 headers
strKey1 = dctHeader(strKey2)
col = dctCol(strKey1)
'update the data for arr2
For i = 3 To 6
arr2(i, j) = arr1(i + 1, col)
Next
Next
'write it back to spreadsheet
trgt.Range("M10").Resize(UBound(arr2), UBound(arr2, 2)) = arr2
End Sub
Please, try the next adapted code.
Public Sub test()
Application.ScreenUpdating = False
stack "Sheet1", "Sheet2", "Mapping"
Application.ScreenUpdating = True
End Sub
Public Sub stack(ByVal Sheet1 As String, ByVal Sheet2 As String, ByVal Mapping As String)
Dim rng As Range, trgtCell As Range, src As Worksheet, trgt As Worksheet, helper As Worksheet
Dim rngSrc As Range, rngDest As Range
Dim sht As Worksheet
Set src = Worksheets(Sheet1)
Set trgt = Worksheets(Sheet2)
Set helper = Worksheets(Mapping)
With src
For Each rng In Intersect(.Rows(3), .UsedRange).SpecialCells(xlCellTypeConstants)
Dim lkup As Variant
With helper
lkup = Application.VLookup(rng.Value, .Range("C2:E" & .Cells(.Rows.Count, "C").End(xlUp).Row), 3, False)
End With
If Not IsError(lkup) Then
Set trgtCell = trgt.Range("$B$2:$F$7").Find(lkup, LookIn:=xlValues, lookat:=xlWhole)
Debug.Print trgtCell.Address
If Not trgtCell Is Nothing Then
With trgt
.Range(trgtCell.Offset(1), .Cells(.Rows.Count, trgtCell.Column).End(xlUp)).Copy
End With
.Range(Split(trgtCell.Address, "$")(1) & 4).PasteSpecial
End If
End If
Next rng
End With
End Sub
Please, also correct the sub calling the second one. You mixed "Shee2" with "Sheet1" there...
Please, test it and send some feedback.
I am trying to work around the tough task to save selected nodes from a TreeView (tough due to my limited VBA knowledge) by first saving a UserID with a TextBox_AfterUpdate Event and subsequently saving the checked node's full path in the rows below when a match is found. Multiple checks are possible, that's why I approached it the way I did below.
I am working on this Problem for 2 working-days now and pray that one of you can help me out of my misery here haha
No Error is produced and a look at the Debugger Shows me that each column in found correctly. Also, the saving user ID via TextBox_AfterUpdate Event works like a treat and should stay this way. It simply does not copy it - please Help.
Thank you in advance!
Private Sub SuppNo_AfterUpdate()
'########Save SuppNo for CG-entry-saving########
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets("Supplier Skills")
Dim lastcol As Long
With ws
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'Copy Supplier No into Row 1 and next empty column
ws.Cells(1, lastcol).Offset(0, 1).Value = Me.SuppNo.Value
End Sub
'------------------------------------------------------------------------------------------
Private Sub CGTreeView_NodeCheck(ByVal Node As MSComctlLib.Node)
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets("Supplier Skills")
Dim myNode As Node
'1. - - Copy Supplier No into Row 1 and next empty column
'Done in SuppNo_Change event
'2.1. - - Find matching entry
Dim aCell As Range
Dim col As Long, lRow As Long, i As Long
Dim colName, NodePath As String
strFind = Me.SuppNo
NodePath = Me.CGTreeView.SelectedItem.FullPath
With ws
Set aCell = .Range("A1:ZZ1").Find(What:=Me.SuppNo, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)
'~~> If Found
If Not aCell Is Nothing Then
col = aCell.Column
colName = Split(.Cells(, col).Address, "$")(1)
lRow = .Range(colName & .Rows.Count).End(xlUp).Row
'2.2. - - Find the last empty row and copy each new FullPath when checked
For i = 2 To 50
If Cells(i, col) Is Nothing Then
ws.Cells(i, col) = NodePath
i = i + 1
End If
Next i
'~~> If not found
Else
Exit Sub
End If
End With
End Sub
I added a few features to eliminate duplicates.
Private Sub SuppNo_AfterUpdate()
'########Save SuppNo for CG-entry-saving########
Dim IDColumn As Long
Dim dItems As Object
Dim c As Range, ItemsRange As Range
Dim n As Node
Set dItems = CreateObject("Scripting.Dictionary")
With ActiveWorkbook.Worksheets("Supplier Skills")
IDColumn = getSuppNoColumn
.Cells(1, IDColumn).Value = Me.SuppNo.Value
Set ItemsRange = .Range(.Cells(2, IDColumn), .Cells(.Rows.count, IDColumn).End(xlUp))
If Not ItemsRange Is Nothing Then
For Each c In ItemsRange
dItems(c.text) = vbNullString
Next
End If
End With
For Each n In CGTreeView.Nodes
n.Checked = dItems.exists(n.FullPath)
Next
End Sub
'------------------------------------------------------------------------------------------
Private Sub CGTreeView_NodeCheck(ByVal Node As MSComctlLib.Node)
Dim IDColumn As Long
Dim dItems As Object
Dim n As Node
If Me.SuppNo.Value <> "" Then
IDColumn = getSuppNoColumn
With ActiveWorkbook.Worksheets("Supplier Skills")
.Range(.Cells(1, IDColumn), .Cells(.Rows.count, IDColumn).End(xlUp)).Offset(1).Clear
Set dItems = CreateObject("Scripting.Dictionary")
For Each n In CGTreeView.Nodes
If n.Checked Then dItems(n.FullPath) = vbNullString
Next
If dItems.count > 0 Then .Cells(2, IDColumn).Resize(dItems.count) = Application.Transpose(dItems.Keys)
End With
End If
End Sub
Function getSuppNoColumn() As Long
Dim f As Range
With ActiveWorkbook.Worksheets("Supplier Skills")
Set f = .Range("1:1").Find(What:=Me.SuppNo, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If f Is Nothing Then
getSuppNoColumn = IIf(.Cells(1, 1) = "", 1, .Cells(1, .Columns.count).End(xlToLeft).Offset(0, 1).Column)
Else
getSuppNoColumn = f.Column
End If
End With
End Function
I am trying to loop through all the worksheets in the activeworkbook to perform a repetitive task.
I currently have the code below:
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim rng1 As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
'This is marking several of the sheets of which I do not want to run the sub
If ws.Range("a9").Value = "x" Then
NextIteration:
End If
'Reference point is rng1 to select the desired range
With Range("a1:t100")
rng1 = .Find(what:="sector", LookIn:=xlValues).Row
End With
'return the row number for the sector header
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
'I am going to add the code below to finish out the task that I want to complete
Next
End Sub
I am sure the problem is that I'm misunderstanding something about how the for each loop actually works. Hopefully someone's answer will allow to better understand.
I really appreciate any help on this.
I made some edits to the code, and now I actually do have an error :) I tried making the changes you suggested for the "with ws.range etc..." piece of the code, and I get the object error 91.
Below is my new and "improved" code.
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim intAnchorRow As Integer
Dim intMktCapAnchor As Integer
Dim intSectorAnchor As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In ActiveWorkbook.Worksheets
'Filter out the sheets that we don't want to run
If ws.Range("a9").Value <> "x" Or ws.Name = "__FDSCACHE__" Or ws.Name = "INDEX" Then
'Get the anchor points for getting sort range and the sort keys
''''''THIS IS THE PART THAT IS NOW GIVING ME THE ERROR'''''''
With ws.Range("a1:t100")
intAnchorRow = .Find(what:="sector", LookIn:=xlValues).Row
intSectorAnchor = .Find(what:="sector", LookIn:=xlValues).Column
intMktCapAnchor = .Find(what:="Market Cap", LookIn:=xlValues).Column
End With
'Find the last row and column of the data range
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
Set SortRng = Range(Cells(intAnchorRow + 1, 1), Cells(LastRow, LastCol))
Range(SortRng).Sort key1:=Range(Cells(intAnchorRow + 1, intSectorAnchor), Cells(LastRow, intSectorAnchor)), _
order1:=xlAscending, key2:=Range(Cells(intAnchorRow + 1, intMktCapAnchor), Cells(LastRow, intMktCapAnchor)), _
order2:=xlDescending, Header:=xlNo
End If
Next
End Sub
Thanks again. This has been very helpful for me.
If I've understood your issue correctly, you don't want to use a worksheet with an x in cell A9.
If that's the case I would change the condition of the if statement to check if the cell does not contain the x. If this is true, it enters the rest of the code. If not, it goes to the next iteration.
Also, your NextIteration: doesn't do anything in the If statement.
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim rng1 As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
'This is marking several of the sheets of which I do not want to run the sub
If ws.Range("a9").Value <> "x" Then
'Reference point is rng1 to select the desired range
With Range("a1:t100")
rng1 = .Find(what:="sector", LookIn:=xlValues).Row
End With
'return the row number for the sector header
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
'I am going to add the code below to finish out the task that I want to complete
End If
Next
End Sub
The : operator is used to return the code to that line after a goto call.
For example
sub gotoEx()
for i = 1 to 10
if i = 5 then
goto jumpToHere
end if
next i
jumpToHere: '<~~ the code will come here when i = 5
'do some more code
end sub
And of course you can use this structure in your code if you wish, and have the jumpToHere: line just before the next
e.g.
for each ws in wb.Worksheets
if ws.Range("a9").Value = "x" then
goto jumpToHere
end if
'the rest of your code goes here
jumpToHere:
next
I need help.
Currently I need to optimize the way i code and the process. Is there an alternative way for me to do this? The only way to differeniate the value is by the the first to digits. And there are hundred over values. As you can see in the codes, 99 will be assign value of 1042, 95 will be assign 261 and this goes on. How do I make it easier so that I have to input the values manually.Thanks in advance guys
Sub Netting()
Dim Found As Range
Dim LR As Long
Dim ws As Worksheet
Dim cell As Range
Dim a As Variant, v As Variant
Set ws = Sheets("PAYABLES - OUTFLOWS")
Set Found = ws.Rows(1).Find(What:="Invoice amount", _
LookIn:=xlValues, lookat:=xlWhole)
If Found Is Nothing Then Exit Sub
a = [{"HI99162152",1042;"HI99162159",1042;"99162161",1042;"HI95400159",261; "HI95400164", 261; "HI97500493",3004;"HI97500497", 3004 }] 'create 2-d lookup array
LR = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
Found.Offset(0, 1).EntireColumn.Insert
ws.Cells(1, Found.Column + 1).Value = "Netting"
For Each cell In ws.Range(ws.Range("C2"), ws.Cells(LR, 3))
v = Application.VLookup(cell.Value, a, 2, False)
cell.EntireRow.Cells(Found.Column + 1).Value = IIf(IsError(v), "", v)
Next cell
End Sub
Sub Netting()
Dim Found As Range
Dim LR As Long
Dim ws As Worksheet
Dim cell As Range
Dim a As Variant, v As Variant, num
Set ws = Sheets("PAYABLES - OUTFLOWS")
Set Found = ws.Rows(1).Find(What:="Invoice amount", _
LookIn:=xlValues, lookat:=xlWhole)
If Found Is Nothing Then Exit Sub
a = [{"99",1042;"95",261;"97",3004}] 'create 2-d lookup array
LR = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
Found.Offset(0, 1).EntireColumn.Insert
ws.Cells(1, Found.Column + 1).Value = "Netting"
For Each cell In ws.Range(ws.Range("C2"), ws.Cells(LR, 3))
num = Cstr(Mid(cell.Value, 3, 2))
v = Application.VLookup(num, a, 2, False)
cell.EntireRow.Cells(Found.Column + 1).Value = IIf(IsError(v), "", v)
Next cell
End Sub
If there are a large number of values in your array then it might be easier to manage that as a table on a worksheet.
I am trying to loop through a column and if cells = "what i'm lookng for" then do something.
I have this so far, where I'm off is in the if statement where I check for the "name":
Option Explicit
Sub test()
Dim wksDest As Worksheet
Dim wksSource As Worksheet
Dim rngSource As Range
Dim name As String
Dim LastRow As Long
Dim LastCol As Long
Dim c As Long
Application.ScreenUpdating = False
Set wksSource = Worksheets("Sheet1")
With wksSource
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For c = 16 To 20
LastRow = .Cells(.Rows.Count, c).End(xlUp).Row
Set rngSource = .Range(.Cells(5, 16), .Cells(LastRow, 16))
name = rngSource.Value
If name = "mark"
do something
End If
Next c
End With
Application.ScreenUpdating = True
'MsgBox "Done!", vbExclamation
End Sub
OK Chris
Maybe a bit of simplification is required but also a few assumptions.
It doesn't seem like LastCol is being used for anything - so let's assume this is the Column you want to loop through.
Your loop has fixed start and end values yet you are determining the LastRow - so let's assume you want to start from row 5 (in your code) and loop to the LastRow in the LastCol.
In order to determine LastCol you must have data in the row you are using to do this - so let's assume that there are values in row 1 in all columns up to column you want to loop say 16 (in your code).
If you want to (IF) test for a single (string) value in this case then you must arrange for your rngSource to be a single cell value. You also don't need to assign this to a variable unless you need to use it again.
Finally, if you want to check for other values you may want to consider using a SELECT CASE structure in place of your IF THEN structure.
Have a look at the following and change my assumptions to meet your requirement - good luck.
Sub test()
Dim wksDest As Worksheet
Dim wksSource As Worksheet
Dim rngSource As Range
Dim name As String
Dim LastRow As Long
Dim LastCol As Long
Dim c As Long
Application.ScreenUpdating = False
Set wksSource = Worksheets("Sheet1")
With wksSource
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LastRow = .Cells(Rows.Count, LastCol).End(xlUp).Row
FirstRow = 5
For c = FirstRow To LastRow
If .Range(.Cells(c, LastCol), .Cells(c, LastCol)).Value = "Mark" Then
MsgBox ("do something")
End If
Next c
End With
End Sub
You can just do that with one line.
If Not IsError(Application.Match(ValueToSearchFor, RangeToSearchIn, 0)) Then
'The value found in the given range
End If
Example:
Search for "Canada" in column C of sheet named "Country"
If Not IsError(Application.Match("Canada", Sheets("Country").Range("C:C"), 0)) Then
'The value found in the given range
End If
Pass value to find and Column where value need to be checked. It will return row num if its found else return 0.
Function checkForValue(FindString As String,ColumnToCheck as String) As Long
SheetLastRow = Sheets("Sheet1").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).row
With Sheets("Sheet1").Range("$" & ColumnToCheck & "$1:$" & ColumnToCheck & "$" & CStr(SheetLastRow) )
Set rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
lookat:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
checkForValue = rng.row 'return row its found
'write code you want.
Else
checkForValue = 0
End If
End With
End Function
I tried Hari's suggestion, but Application.Match works weird on range names (not recognizing them...)
Changed to: WorksheetFunction.Match(...
It works, but when value is not present A runtime ERROR jumps before IsError(...) is evaluated.
So I had to write a simple -no looping- solution:
dim Index as Long
Index = -1
On Error Resume Next
Index = WorksheetFunction.Match(Target,Range("Edificios"), 0) 'look for Target value in range named: Edificios
On Error GoTo 0
If Index > 0 Then
' code for existing value found in Range # Index row
End If
Remeber Excel functions first index = 1 (no zero based)
Hope this helps.
I'm guessing what you really want to do is loop through your range rngSource. So try
Set rngSource = .Range(.Cells(5, 16), .Cells(LastRow, 16))
for myCell in rngSource
if myCell.Value = "mark" then
do something
end if
next myCell