When I press F8 to step through the code line by line, it works perfect. However when I use F5 to run the the whole sub, VBA just runs one For-Next Loop. I am wondering if anyone is having the same issue?
Sub InputPurchaseData()
Dim rngPurchaseInfoLoop As Range, rngPurchaseInfo As Range
Dim rngPurchaseItemsFieldLoop As Range, rngPurchaseItemsField As Range
Dim rngPurchaseItemsLoop As Range, rngPurchaseItems As Range
Dim rngPurchaseDataFieldLoop As Range, rngPurchaseDataField As Range
Dim rngPurchaseDataRowLoop As Range, rngPurchaseDataRow As Range
Dim lngPurchaseItemRow As Long, lngPurchaseDataRow As Long
Dim msgOption As Boolean
Dim strPurchaseNumber As String
wsPurchaseOrder.Activate
Set rngPurchaseInfo = wsPurchaseOrder.Range("A1").CurrentRegion
Set rngPurchaseItemsField = wsPurchaseOrder.Range("B1", Range("B1048576").End(xlUp)).Find(What:="ITEM", _
MatchCase:=True, LookAt:=xlWhole)
Set rngPurchaseItems = Range(rngPurchaseItemsField.Offset(2, 0), Range("B1048576").End(xlUp).Offset(-1, 0))
Set rngPurchaseItemsField = Range(rngPurchaseItemsField, rngPurchaseItemsField.End(xlToRight))
Set rngPurchaseDataField = wsPurchaseData.Range("A1").CurrentRegion.Resize(1)
Set rngPurchaseDataRow = wsPurchaseData.Range("A1").CurrentRegion.Resize(, 1)
For Each rngPurchaseItemsLoop In rngPurchaseItems
If IsNumeric(rngPurchaseItemsLoop.Value) Then
lngPurchaseItemRow = rngPurchaseItemsLoop.Row - rngPurchaseItems.Resize(1).Row + 2
For Each rngPurchaseInfoLoop In rngPurchaseInfo
Set rngPurchaseDataFieldLoop = rngPurchaseDataField.Find(What:=rngPurchaseInfoLoop.Value, MatchCase:=True, LookAt:=xlWhole)
If Not rngPurchaseDataFieldLoop Is Nothing Then _
rngPurchaseDataFieldLoop.Offset(rngPurchaseDataRow.Rows.Count).Value = rngPurchaseInfoLoop.Offset(, 1).Value
Next rngPurchaseInfoLoop
For Each rngPurchaseItemsFieldLoop In rngPurchaseItemsField
Set rngPurchaseDataFieldLoop = rngPurchaseDataField.Find(What:=rngPurchaseItemsFieldLoop.Value, MatchCase:=True, LookAt:=xlWhole)
If Not rngPurchaseDataFieldLoop Is Nothing Then _
rngPurchaseDataFieldLoop.Offset(rngPurchaseDataRow.Rows.Count).Value = rngPurchaseItemsFieldLoop.Offset(lngPurchaseItemRow).Value
Next rngPurchaseItemsFieldLoop
End If
Next rngPurchaseItemsLoop
End Sub
Related
I have a SourceFile.xlsm that contains an X number of field definitions and their contents:
I want to put the contents of these fields into a TargetFile.xlsx, that may contain 0 or more of those field definitions:
The expected end result would be this:
But the actual end result is always this:
And that is because this line in the code below:
Set source_range = sourceSheet.Cells.FindNext(source_range)
always keeps coming back to the first occurrence (cell B5, containing "[Field 1]"), instead of the next (cell B6, containing "[Field 2]"):
Function CopyFromSourceToTarget()
Dim sourceWB As Workbook
Dim targetWB As Workbook
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim source_range As Range
Dim target_range As Range
Dim FirstFound_source As String
Dim FirstFound_target As String
Set sourceWB = ActiveWorkbook
Set targetWB = Workbooks.Open("C:\TEMP\TargetFile.xlsx")
For Each sourceSheet In sourceWB.Worksheets
Set source_range = sourceSheet.Cells.Find("[", LookIn:=xlValues)
If Not source_range Is Nothing Then
FirstFound_source = source_range.Address
Debug.Print source_range.Value
Do
sourceWB.Activate
source_range.Select
For Each targetSheet In targetWB.Worksheets
Set target_range = targetSheet.Cells.Find(source_range.Value, LookIn:=xlValues)
If Not target_range Is Nothing Then
FirstFound_target = target_range.Address
Do
target_range.FormulaR1C1 = CStr(source_range.Offset(0, 1).Value)
Set target_range = targetSheet.Cells.FindNext(target_range)
If target_range Is Nothing Then Exit Do
Loop Until target_range.Address = FirstFound_target
End If
Next
Set source_range = sourceSheet.Cells.FindNext(source_range)
Debug.Print source_range.Value
Loop Until source_range.Address = FirstFound_source
End If
Next
End Function
I've tried several options, but all to no avail. Hopefully, someone here can help me along, because this seemingly very simple issue is driving me nuts.
Instead of this line:
Set source_range = sourceSheet.Cells.FindNext(source_range)
try this line:
Set source_range = sourceSheet.Cells.Find(What:="[", After:=source_range, LookIn:=xlValues)
I'd also add some more options to the Find like LookAt:= xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False, but it might not be necessary. Up to you.
I created a variable oldPassword which is populated using a VLookup.
I am trying to get now the cell address from that result but nothing seem to work.
Dim oldPassword As String
oldPassword = Application.WorksheetFunction.VLookup(Me.ComboBox1.Value, Worksheets("Employees").Range("A:B"), 2, False)
You should break the task into steps
Get a reference to the cell containing the search value
Use that reference to get the required value and address
Sub Demo
Din rSearch As Range
Dim rUser as Range
Dim rPassword As Range
Dim idx As Variant
Set rSearch = Worksheets("Employees").Range("A:B")
idx = Application.Match(Me.ComboBox1.Value, rSearch.Columns(1), 0)
If Not IsError(idx) Then
Set rUser = rSearch.Cells(idx, 1)
Set rPassword = rUser.Cells(1, 2)
' get the result
oldPassword = rPassword.Value2
' get the address
Debug.Print rPassword.Address
End If
End Sub
I would prefer using .Find as #Andreas suggested but then that is my personal preference.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Employees")
Dim aCell As Range
Set aCell = ws.Columns(1).Find(What:=ComboBox1.Value, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Dim oldPassword As String
If Not aCell Is Nothing Then
With aCell.Offset(, 1)
'~~> Do what you want with that cell
oldPassword = .Value2
MsgBox .Address
End With
Else '<~~ Optional
MsgBox ComboBox1.Value & " not found!"
End If
End Sub
I want to break up this line of code, to make it more digestible, in smaller steps, but I am running in problems that I either get compile errors, run time errors, or just plain the wrong response.
As a beginner in coding of VBA, maybe somebody enlightens me, why it is not possible, or if it is possible where I am going wrong with my approach.
This code is functional snippet is below, but the function following is not
Dim WksN As String
Dim res As Object
' Set res = Sheets("Sheet3").Cells(1, 1).EntireRow.Find(What:=name
Set res = Sheets(WksN).Cells(1, 1).EntireRow.Find(What:=name _
, LookIn:=xlValues _
, LookAt:=xlPart _
, SearchOrder:=xlByColumns _
, SearchDirection:=xlPrevious _
, MatchCase:=False)
Public Function GetColumnNumber(ByVal WksN As String, _
ByVal name As String) As Long
Dim wks As Worksheet
Dim rng As Range
Dim res As Object
Dim clmn As Object
' Set wks = ActiveWorkbook.Worksheets(CStr(WksN))
' Set wks = Sheets(CStr(WksN))
' Set wks = Sheets(CStr(WksN)).Activate
' Set wks = ActiveWorkbook.Worksheets(CStr(WksN)).Activate
Set wks = ActiveWorkbook.Worksheets(CStr(WksN)) '
' Set rng = wks.Cells(1, 1).EntireRow.Select ' Run time error
' Set rng = wks.Activate ' Not needed ??
' Set rng = wks.Rows(1).Select ' Compile error
Set rng = wks.Rows(1)
' With wks.Cells(1, 1).EntireRow ' Didn't work
With rng
Set clmn = .Find(What:=name, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
End With
If res Is Nothing Then
GetColumnNumber = 0
Else
GetColumnNumber = clmn.Column
End If
End Function
I would like to set the range of the entire first row and then
search and find the column in which my string is stored.
I am not sure if the statement from above is atomic and can't be broken up,
or how I am not activating or selecting the "right" range, as the return value of this function is zero when the return value of the first code snippet is none zero and correct.
The second question I have that I seem not to select the range when I am using the .Rows(1) statement, which strikes me that I must fundamentally not understand how this is supposed to work.
Set rng = wks.Cells(1, 1).EntireRow.Select ' Run time error
Select does not return a value, so don't use that if you're trying to get a reference to a range
Set rng = wks.Cells(1, 1).EntireRow
This should work:
Public Function GetColumnNumber(ByVal WksN As String, _
ByVal hdr As String) As Long
Dim f As Range
Set f = ActiveWorkbook.Worksheets(WksN).Rows(1).Find( _
what:=hdr, LookIn:=xlValues, lookat:=xlPart)
If f Is Nothing Then
GetColumnNumber = 0
Else
GetColumnNumber = f.Column
End If
End Function
The code below gives either Mismatch or Range error in Excel 2008. How do I fix it?
Sub PEC()
Dim PEC As String, result As Integer
PEC = Range("AE2:AE26848").Value
If PEC = "A.06" Then result = 1
Range("AO2:AO26848").Value = result
End Sub
Sub PEC()
For x = 2 to 26848
If Range("AE" & x) = "A.06" Then Range("AO" & x) = 1
Next x
End Sub
I recommend using the following code. It might seem more complicated, but it certainly does a better and more robust job. It is simply assigning your input and output ranges as SrcRng and DstRng. FIND method for ranges is a good way to check for specific values.
Sub PEC()
Dim SrcRng As Range
Dim DstRng As Range
Dim rcell As Range
Set SrcRng = Range ("AE2:AE26848")
Set DstRng = Range("AO2:AO26848")
Set rcell = SrcRng.Find(what:="A.06", after:=SrcRng.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not rcell Is Nothing Then
DstRng.Value = 1
End If
End Sub
Dim Counter As Integer
Dim Maxhouse As Integer
Dim FindHouse As Range
Dim RangeVar As Range
Dim HousesRange As Range
For Counter = 1 To MaxHouse
ActiveSheet.Cells(16, 2 + Counter).Select
House = ActiveCell
With Sheets("Sheet1").Range("C:KP")
Set FindHouse = Cells.Find(What:=House, _
After:=Cells(17, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not FindHouse Is Nothing Then
If Counter = 1 Then
Set HousesRange = FindHouse
Else
Set RangeVar = FindHouse
Set HousesRange = Union(HousesRange, RangeVar)
End If
End If
End With
Next Counter
For Each RCell In HousesRange.Cells
Application.Goto RCell, True
Next RCell**
Now my problem is with the for loop which traverses through the named range 'HousesRange'
So lets say that HousesRange contains [2,5,9,10].
Here HousesRange is a subset of the row [1,2,3,4,5,6,7,8,9,10] in my Sheet
And lets assume that HousesRange was established through the order of [9,10,5,2] (through the 1st for loop with the union).
Now as I traverse through HousesRange with just rCells (the second for loop), it takes me to 9, 10, 5 then 2.
But I want it to take me to 2, 5, 9 then 10
Can some body shed some light to this?
I had always thought that named ranges are ALWAYS traversed through left to right and then top to bottom.
Thank you so much in advance
Ok this is the long way round, but it should work:
Instead of using Union build your list of found houses in a dictionary object.
Then sort the ranges using Bubblesort HouseRangeDic
You should finally be able to use it in the right order:
Dim Counter As Integer
Dim Maxhouse As Integer
Dim FindHouse As Range
Dim RangeVar As Range
Dim HousesRange As Range
'****** NEW **********
Dim foundHouseCount
foundHouseCount = 1
Dim HouseRangeDic
Set HouseRangeDic = CreateObject("Scripting.dictionary")
'*********************
For Counter = 1 To Maxhouse
ActiveSheet.Cells(16, 2 + Counter).Select
House = ActiveCell
With Sheets("Sheet1").Range("C:KP")
Set FindHouse = Cells.Find(What:=House, _
After:=Cells(17, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not FindHouse Is Nothing Then
HouseRangeDic.Add foundHouseCount, RangeVar '**** NEW ***
foundHouseCount = foundHouseCount + 1 '**** NEW ***
End If
End With
Next Counter
'**** NEW ***
Bubblesort HouseRangeDic
For i = 1 To HouseRangeDic.Count
Application.Goto HouseRangeDic(i), True
Next
'************
Sub Bubblesort(ByRef rangeDic)
Dim tempRange
For i = 1 To rangeDic.Count - 1
For j = i To rangeDic.Count
If rangeDic(i).Address > rangeDic(j).Address Then
Set tempRange = rangeDic(i)
Set rangeDic(i) = rangeDic(j)
Set rangeDic(j) = tempRange
End If
Next
Next
End Sub
See if this works for you. Notice my "After:=" is set to the LAST cell of the range, so the first find starts at the beginning of the range.
Sub loopCells()
Dim FindHouse As Range
Dim HousesRange As Range
Dim rcell As Range
Dim r As Range
Dim sAdd As String
Dim House As Long
Set r = Sheets("Sheet1").Range("$C$15:$K$20") 'change to suit
House = 11'change to suit
With r
Set FindHouse = .Find(What:=House, After:=r(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not FindHouse Is Nothing Then
sAdd = FindHouse.Address
Do
If HousesRange Is Nothing Then
Set HousesRange = FindHouse
Else
Set HousesRange = Union(HousesRange, FindHouse)
End If
Set FindHouse = .FindNext(FindHouse)
Loop While Not FindHouse Is Nothing And FindHouse.Address <> sAdd
End If
End With
For Each rcell In HousesRange
Application.Goto rcell
Next rcell
End Sub