This is a for loop to find values in a range and create new array full of match results. Problem is viewing the object I see at the first If statement AR2(i) creates an element AR2(0) which is empty then assigns AR2(1) as the If Else value.
Sub rt()
Dim AR0() As Variant, AR1() As Variant, AR2() As Variant
Dim WS0 As Worksheet, WS1 As Worksheet
Dim i As Integer, RW0 As Integer, RW1 As Integer
Dim C As Range
Set WS0 = Sheets("lookup")
Set WS1 = Sheets("centro")
RW1 = WS1.Cells(WS1.Rows.Count, "A").End(xlUp).row
AR0 = WS0.Range("A3:A28")
For i = 1 To UBound(AR0, 1)
With WS1.Range("A2:A" & RW1)
Set C = .find(AR0(i, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
ReDim Preserve AR2(i)
If Not C Is Nothing Then
AR2(i) = "YES"
Else
AR2(i) = " - "
End If
End With
Next
WS0.Range("B3:B28") = WorksheetFunction.Transpose(AR2)
End Sub
Error was with AR2 creating element AR2(0) without having value assigned. Solution was to set For loop to start from 0 and AR0(i +1, 1) to allow to find this value starting from loop position 0. Thanks!
Sub rt()
Dim AR0() As Variant, AR1() As Variant, AR2() As Variant
Dim WS0 As Worksheet, WS1 As Worksheet
Dim i As Integer, RW0 As Integer, RW1 As Integer
Dim C As Range
Set WS0 = Sheets("lookup")
Set WS1 = Sheets("centro")
RW1 = WS1.Cells(WS1.Rows.Count, "A").End(xlUp).row
AR0 = WS0.Range("A3:A28")
For i = 0 To UBound(AR0, 1) - 1
With WS1.Range("A2:A" & RW1)
Set C = .find(AR0(i + 1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
ReDim Preserve AR2(i)
If Not C Is Nothing Then
AR2(i) = "YES"
Else
AR2(i) = " - "
End If
End With
Next
WS0.Range("B3:B28") = WorksheetFunction.Transpose(AR2)
End Sub
Related
I would like to have up to 6 records which will be based on the answers located in the row beneath.
My code so far looks like this:
Sub Copy_Data_Correctly(ByRef datSource As Worksheet, datTarget As Worksheet)
'QUESTION 1
Const TM_PM As String = "*PM is required*"
Dim que1 As Range
Dim ans1 As Range
Set que1 = Sheets("Sheet1").Range("A1:A100").Find(What:=TM_PM, _
Lookat:=xlPart, LookIn:=xlValues)
If Not que1 Is Nothing Then
'MsgBox ("The question about PM or TM wasn't found")
End If
Set ans1 = que1.Offset(1)
'QUESTION 2
Const LID_LIFTED As String = "*be lifted*"
Dim que2 As Range
Dim ans2 As Range
Set que2 = Sheets("Sheet1").Range("A1:A100").Find(What:=LID_LIFTED, _
Lookat:=xlPart, LookIn:=xlValues)
If Not que2 Is Nothing Then
End If
Set ans2 = que2.Offset(1)
'EXTRACTING THE DATA
Dim lrow1 As Long, lrow2 As Long, lrow3 As Long, lrow4 As Long, lrow5 As Long, lrow6 As Long
lrow1 = datTarget.Range("E" & datTarget.Rows.Count).End(xlUp).Row + 1
lrow2 = datTarget.Range("F" & datTarget.Rows.Count).End(xlUp).Row + 1
que1.Copy
datTarget.Range("E1").PasteSpecial xlPasteValuesAndNumberFormats
ans1.Copy
datTarget.Range("E" & lrow1).PasteSpecial xlPasteValuesAndNumberFormats
que2.Copy
datTarget.Range("F1").PasteSpecial xlPasteValuesAndNumberFormats
ans2.Copy
datTarget.Range("F" & lrow2).PasteSpecial xlPasteValuesAndNumberFormats
End Sub
If I have the second question & answer standalone, then it works. Unfortunately after adding the Q&A1 the error:
Object variable or with variable not set
occurs at the line:
Set ans1 = que1.Offset(1)
why the code behaves like that?
Copy Conditionally
Using the Find method, it will attempt to find each string, containing wild characters, from a list in range A1:A100 of one worksheet (source), then take this matching value (which is different (no wild characters)), and by using Application.Match, it will attempt to find a match in the headers of another worksheet (destination). If a match is found, then the result, the value of the cell below the previously found cell, will be written into the first available row. If no match is found, a new header will be created from the value of the found cell, and the value below the found cell will be written into the first available row.
Option Explicit
Sub CopyData( _
ByVal wsSource As Worksheet, _
ByVal wsDestination As Worksheet)
' Add more: comma separated, no spaces
Const sCriteriaList As String = "*PM is required,*be lifted*"
Const sCriteriaListDelimiter As String = ","
Const sAddress As String = "A1:A100"
Const dfhCellAddress As String = "E1"
Dim sCriteria() As String
sCriteria = Split(sCriteriaList, sCriteriaListDelimiter)
Dim srg As Range: Set srg = wsSource.Range(sAddress)
Dim dfhCell As Range: Set dfhCell = wsDestination.Range(dfhCellAddress)
Dim dfRow As Long: dfRow = dfhCell.Row
Dim dfCol As Long: dfCol = dfhCell.Column
Dim dlhCell As Range: Set dlhCell = _
wsDestination.Cells(dfRow, wsDestination.Columns.Count).End(xlToLeft)
Dim dhrg As Range
If dlhCell.Column < dfCol Then
Set dhrg = dfhCell
Else
Set dhrg = wsDestination.Range(dfhCell, dlhCell)
End If
Dim dlCol As Long: dlCol = dhrg.Columns(dhrg.Columns.Count).Column
Dim dlCell As Range
Set dlCell = _
wsDestination.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)
Dim dRow As Long
If Not dlCell Is Nothing Then
If dlCell.Row <= dfhCell.Row Then
dRow = dfhCell.Row + 1
Else
dRow = dlCell.Row + 1
End If
Else
dRow = dfhCell.Row + 1
End If
Dim sCell As Range
Dim sQuestion As String
Dim sAnswer As String
Dim drrg As Range
Dim dhIndex As Variant
Dim n As Long
For n = 0 To UBound(sCriteria)
Set sCell = srg.Find( _
sCriteria(n), srg.Cells(srg.Cells.Count), xlValues, xlWhole)
If Not sCell Is Nothing Then
sQuestion = sCell.Value
sAnswer = CStr(sCell.Offset(1).Value)
dhIndex = Application.Match(sQuestion, dhrg, 0)
If IsNumeric(dhIndex) Then
wsDestination.Cells(dRow, dhIndex + dfCol - 1).Value = sAnswer
Else
Set dhrg = dhrg.Resize(, dhrg.Columns.Count + 1)
dlCol = dlCol + 1
wsDestination.Cells(dfRow, dlCol).Value = sQuestion
wsDestination.Cells(dRow, dlCol).Value = sAnswer
End If
End If
Next n
End Sub
im sorry for making similar question but im run into a problem, bcs i don t know very good VBA coding...
I found many similar questions, and i found a code that i can apply to my needs.
I found code here But i don't know how to edit that code so that he can work in my Workbook. I have workbook with 35 worksheets, all with same format, values are in columns "A:F", in column "E" i have text "On Stock" and "Sent", i want all rows from all worksheets that have "On Stock" value in column "E" to be copied into one worksheet named "Blanko List". I tried to edit code myself, but it can t run, nothing happens. Thanks in advance.
Edited code
Sub CommandButton4_Click()
Dim wM As Worksheet, ws As Worksheet
Dim r As Long, lr As Long, nr As Long, y As Long
Dim c As Range, firstaddress As String
Application.ScreenUpdating = False
Set wM = Sheets("Blanko List")
lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
If lr > 1 Then wM.Range("A2:G" & lr).ClearContents
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Blanko List" Then
y = 0
On Error Resume Next
y = Application.CountIf(ws.Columns(7), "On Stock")
On Error GoTo 0
If y > 1 Then
firstaddress = ""
With ws.Columns(7)
Set c = .Find("On Stock", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
nr = wM.Range("G" & Rows.Count).End(xlUp).Offset(1).Row
ws.Range("A" & c.Row & ":G" & c.Row).Copy wM.Range("A" & nr)
Application.CutCopyMode = False
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End If
End If
Next ws
wM.Activate
Application.ScreenUpdating = True
''''
Original code:
Option Explicit
Sub GetYes()
Dim wM As Worksheet, ws As Worksheet
Dim r As Long, lr As Long, nr As Long, y As Long
Dim c As Range, firstaddress As String
Application.ScreenUpdating = False
Set wM = Sheets("Master")
lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
If lr > 1 Then wM.Range("A2:G" & lr).ClearContents
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Master" Then
y = 0
On Error Resume Next
y = Application.CountIf(ws.Columns(7), "Yes")
On Error GoTo 0
If y > 1 Then
firstaddress = ""
With ws.Columns(7)
Set c = .Find("Yes", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
nr = wM.Range("G" & Rows.Count).End(xlUp).Offset(1).Row
ws.Range("A" & c.Row & ":G" & c.Row).Copy wM.Range("A" & nr)
Application.CutCopyMode = False
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End If
End If
Next ws
wM.Activate
Application.ScreenUpdating = True
End Sub
Copy Criteria Rows
Option Explicit
Sub CopyCriteriaRows()
' Source
Const sCols As String = "A:F"
Const sfRow As Long = 2
Const scCol As Long = 5
Const sCriteria As String = "On Stock"
' Destination
Const dName As String = "Blanco List"
Const dFirst As String = "A2"
' Exceptions
Const ExceptionsList As String = "Blanco List" ' add more
Const ListSeparator As String = ","
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the names of the worksheets to be 'processed' to an array.
Dim wsNames As Variant
wsNames = ArrWorksheetNames(wb, ExceptionsList, ListSeparator)
If IsEmpty(wsNames) Then Exit Sub ' no worksheet found
' Create a reference to the first destination row range.
' Note that the number of columns is equal in source and destination.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim cCount As Long: cCount = dws.Columns(sCols).Columns.Count
Dim drrg As Range: Set drrg = dws.Range(dFirst).Resize(, cCount)
Dim sws As Worksheet ' Source Worksheet
Dim srg As Range ' Source Range
Dim sfrrg As Range ' Source First Row Range
Dim drg As Range ' Destination Range
Dim Data As Variant ' Data Array
Dim cValue As Variant ' Current Value
Dim dr As Long ' Destination Row Counter
Dim sr As Long ' Source Row Counter
Dim c As Long ' Column Counter
For Each sws In wb.Worksheets(wsNames)
' Create a reference to the current Source First Row Range.
Set sfrrg = sws.Columns(sCols).Rows(sfRow)
Set srg = Nothing
' Create a reference to the current Source Range.
Set srg = RefColumns(sfrrg)
If Not srg Is Nothing Then ' the current Source Range is not empty
' Write the values from the current Source Range to the Data Array.
Data = GetRange(srg)
' Write the matches to the top of the Data Array. The size
' of the array stays the same but 'dr' is used: to track
' the number of, to move, and finally, to write (to the worksheet)
' the 'destination' values.
dr = 0
For sr = 1 To UBound(Data, 1)
cValue = Data(sr, scCol)
If StrComp(CStr(cValue), sCriteria, vbTextCompare) = 0 Then
dr = dr + 1
For c = 1 To cCount
Data(dr, c) = Data(sr, c)
Next c
End If
Next sr
If dr > 0 Then ' there have been matches
' Create a reference to the Destination Range.
Set drg = drrg.Resize(dr)
' Write only the 'destination' values (dr) from
' the Data Array to the Destination Range.
drg.Value = Data
' Create a reference to the next Destination First Row Range.
Set drrg = drrg.Offset(dr)
End If
End If
Next sws
' The 'Clear Range' is the range spanning
' from the last 'Destination First Row Range'
' (which was referenced, but was not written to)
' to the bottom-most row range of the worksheet.
Dim crg As Range
Set crg = drrg.Resize(dws.Rows.Count - drrg.Row + 1)
crg.ClearContents
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the names of the worksheets of a workbook ('wb'),
' that are not included in a list ('ExceptionsList'),
' in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrWorksheetNames( _
ByVal wb As Workbook, _
Optional ByVal ExceptionsList As String = "", _
Optional ByVal ListSeparator As String = ",", _
Optional ByVal FirstIndex As Long = 0) _
As Variant
If wb Is Nothing Then Exit Function
Dim wsCount As Long: wsCount = wb.Worksheets.Count
If wsCount = 0 Then Exit Function ' There could e.g. only be charts.
Dim IndexDiff As Long: IndexDiff = FirstIndex - 1
Dim LastIndex As Long: LastIndex = wsCount + IndexDiff
Dim Arr() As String: ReDim Arr(FirstIndex To LastIndex)
Dim n As Long: n = IndexDiff
Dim ws As Worksheet
If Len(ExceptionsList) = 0 Then
For Each ws In wb.Worksheets
n = n + 1
Arr(n) = ws.Name
Next ws
Else
Dim Exceptions() As String
Exceptions = Split(ExceptionsList, ListSeparator)
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
n = n + 1
Arr(n) = ws.Name
End If
Next ws
End If
Select Case n
Case IndexDiff
Exit Function
Case Is < LastIndex
ReDim Preserve Arr(FirstIndex To n)
End Select
ArrWorksheetNames = Arr
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range spanning from the first row
' of a given range ('rg') to the row containing the bottom-most
' non-empty cell of the given range's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
ByVal rg As Range) _
As Range
If rg Is Nothing Then Exit Function
With rg.Rows(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function ' empty range
Set RefColumns = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
Dim rData As Variant
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell only
ReDim rData(1 To 1, 1 To 1): rData(1, 1) = rg.Value
Else
rData = rg.Value
End If
GetRange = rData
End Function
' Irrelevant to the Question,
' but for a better understanding of `ArrWorksheetNames`.
Sub ArrWorksheetNamesTEST()
Const ExceptionsList As String = "Sheet1,Sheet2,Sheet3,Sheet4"
Const ListSeparator As String = ","
Const FirstIndex As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsNames As Variant
wsNames = ArrWorksheetNames(wb, ExceptionsList, ListSeparator, FirstIndex)
If IsEmpty(wsNames) Then
Debug.Print "No worksheets."
Else
Debug.Print "[" & LBound(wsNames) & "," & UBound(wsNames) & "]" _
& vbLf & Join(wsNames, vbLf)
End If
End Sub
You can use this to develop an array of values and then dump them into some collection sheet.
Sub grabAllSheets()
Const exclude_Sheet = "Result" ' name of sheet to drop data
Const tangoText = "On Stock"
Dim ws As Worksheet, aCell As Range
ReDim allvalues(1 To 6, 1 To 1)
Dim i As Long, c As Long
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> exclude_Sheet Then
For Each aCell In Intersect(ws.Range("E:E"), ws.UsedRange).Cells
If aCell.Value = tangoText Then
i = i + 1
ReDim Preserve allvalues(1 To 6, 1 To i)
For c = 1 To Range("F:F").Column
allvalues(c, i) = ws.Cells(aCell.Row, c).Value
Next c
End If
Next aCell
End If
Next ws
Dim theRow As Long
With Sheets(exclude_Sheet)
theRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(IIf(theRow = 1, 1, theRow + 1), 1).Resize(i, 6).Value = _
Application.WorksheetFunction.Transpose(allvalues)
End With
End Sub
I have three worksheets, Pre-visit, Item List, and Search.
Pre-visit is the form. Item list is a database of all product codes and descriptions. Search is the worksheet I found. The search sheet works.
I moved the Search button from Search to Pre-visit and now it won't work.
Sub SearchParts()
Dim arrParts() As Variant
Dim sht As Worksheet, actsht As Worksheet
Set sht = ThisWorkbook.Worksheets("Search")
sht.range("A7", "B" & Cells(Rows.CountLarge, "B").End(xlDown).Row).Clear
arrParts = FindParts(CStr(Trim(Cells(2, 2))))
sht.range("A7").Resize(UBound(arrParts, 2), UBound(arrParts)) = _
WorksheetFunction.Transpose(arrParts)
End Sub
Original code
Sub SearchParts()
Dim arrParts() As Variant
range("A7", "B" & Cells(Rows.CountLarge, "B").End(xlDown).Row).Clear
arrParts = FindParts(CStr(Trim(Cells(2, 2))))
range("A7").Resize(UBound(arrParts, 2), UBound(arrParts)) = _
WorksheetFunction.Transpose(arrParts)
End Sub
Private Function FindParts(PartNumber As String) As Variant
Dim ws As Worksheet
Dim FoundCell As range
Dim LastCell As range
Dim rngParts As range
Dim FirstAddr As String
Dim arrPart() As Variant
Set ws = Worksheets("Item list")
Set rngParts = ws.range("B5:B" & ws.Cells(Rows.CountLarge, "B").End(xlUp).Row)
With rngParts
Set LastCell = .Cells(.Cells.Count)
End With
Set FoundCell = rngParts.Find(What:=PartNumber, After:=LastCell, LookAt:=xlPart)
If Not FoundCell Is Nothing Then
FirstAddr = FoundCell.Address
End If
ReDim arrPart(1 To 2, 1 To 1)
Do Until FoundCell Is Nothing
arrPart(1, UBound(arrPart, 2)) = FoundCell.Offset(0, -1)
arrPart(2, UBound(arrPart, 2)) = FoundCell.Value
ReDim Preserve arrPart(1 To 2, 1 To UBound(arrPart, 2) + 1)
Set FoundCell = rngParts.FindNext(After:=FoundCell)
If FoundCell.Address = FirstAddr Then
Exit Do
End If
Loop
FindParts = arrPart
End Function
# This is the input table for which I want to perform some action #
Public Sub mac()
Dim RangeOfChild As Range
For i = 1 To 10000
ActiveCell.Range("A" & i).Activate
Dim DirArray As Variant
Dim temp As Variant
Set RangeOfChild = Range(ActiveCell.Offset(0, 1),ActiveCell.End(xlToRight))
childCount = RangeOfChild.count
temp = ActiveCell.Value
ActiveCell = Null
DirArray = RangeOfChild.Value
RangeOfChild.ClearContents
ActiveCell.EntireRow.Resize(childCount - 1).Insert Shift:=xlDown
ActiveCell.Value = temp
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(RangeOfChild.count - 1, 1)) = Application.Transpose(Array(DirArray))
i = i + (childCount)
Next i
End Sub
I want a output similar to the below image
enter image description here
But the written for loop is only doing the operation to two of the rows , not the remaining, If someone could help me out with this , it would be a great help.
I accomplished this task by using two worksheets: worksheets("SheetInput") which contains the input data and worksheets("SheetOutput") which receives the formatted output.
Option Explicit
Public Sub mac()
Dim wsData As Worksheet, wsOutput As Worksheet
Dim rngInput As Range, RangeOfChild As Range, rngOutput As Range
Dim childCount As Long
Set wsData = ThisWorkbook.Worksheets("SheetInput")
Set wsOutput = ThisWorkbook.Worksheets("SheetOutput")
Set rngInput = ThisWorkbook.Worksheets("SheetInput").Cells(1, 1)
Set rngOutput = ThisWorkbook.Worksheets("SheetOutput").Cells(1, 1)
While Not (IsEmpty(rngInput))
Set RangeOfChild = Range(rngInput.Offset(0, 1), rngInput.End(xlToRight))
childCount = RangeOfChild.Count
rngInput.Copy
rngOutput.PasteSpecial Paste:=xlPasteAll
RangeOfChild.Copy
rngOutput.Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Set rngInput = rngInput.Offset(1, 0)
Set rngOutput = rngOutput.Offset(childCount, 0)
Wend
End Sub
activate method is not good. use a variant array.
Sub test()
Dim rngDB As Range, rngCnt As Range
Dim rng As Range, rng2 As Range
Dim vCnt, vR()
Dim i As Integer, c As Integer, n As Long, s As Long
Set rngDB = Range("a1", Range("a" & Rows.Count).End(xlUp))
For Each rng In rngDB
Set rngCnt = Range(rng.Offset(, 1), rng.End(xlToRight))
s = n + 1
vCnt = rngCnt
c = rngCnt.Columns.Count
n = n + c
ReDim Preserve vR(1 To 2, 1 To n)
vR(1, s) = rng
For i = 1 To c
vR(2, s + i - 1) = vCnt(1, i)
Next i
Next rng
Sheets.Add
Range("a1").Resize(n, 2) = WorksheetFunction.Transpose(vR)
End Sub
I am trying to sort columns alphabetically based on the values of cells in Row 2.
Can't figure out what's wrong here - it seems to work only for the first column and then it stops.
Sub reorganise()
Dim v As Variant, x As Variant, findfield As Variant
Dim oCell As Range
Dim iNum As Long
Dim wsa As Worksheet
Set wsa = Worksheets("Skills")
v = Array(wsa.Range("B2", wsa.Cells(2, wsa.Columns.Count).End(xlToLeft)))
For x = LBound(v) To UBound(v)
findfield = v(x)
iNum = iNum + 1
Set oCell = wsa.Rows(2).Find(What:=findfield, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not oCell.Column = iNum Then
Columns(oCell.Column).Cut
Columns(iNum).Insert Shift:=xlToRight
End If
Next x
End Sub
Ok I have figured it out.. was a bit more complicated but here is the full code:
Sub reorganise()
Dim v
Dim x
Dim findfield As Variant
Dim oCell As Range
Dim iNum As Long
Dim wsa As Worksheet
Dim inputArray() As Variant
Set wsa = Worksheets("Skills")
With wsa
Set v = .Range("A2", .Cells(2, .Columns.Count).End(xlToLeft))
End With
v = Application.Transpose(v)
Call BubbleSort(v)
For x = LBound(v, 1) To UBound(v, 1)
findfield = v(x, 1)
iNum = iNum + 1
Set oCell = wsa.Rows(2).Find(What:=findfield, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not oCell.Column = iNum Then
Columns(oCell.Column).Cut
Columns(iNum).Insert Shift:=xlToRight
End If
Next x
End Sub
Sub BubbleSort(arr)
Dim strTemp As String
Dim i As Long
Dim j As Long
Dim lngMin As Long
Dim lngMax As Long
lngMin = LBound(arr, 1)
lngMax = UBound(arr, 1)
For i = lngMin To lngMax - 1
For j = i + 1 To lngMax
If arr(i, 1) > arr(j, 1) Then
strTemp = arr(i, 1)
arr(i, 1) = arr(j, 1)
arr(j, 1) = strTemp
End If
Next j
Next i
End Sub
Basically in addition to what you said, I had to:
Transpose the array
Change the LBound and Ubound and findfield syntax
Come up with an additional procedure to sort out the values of the array alphabetically
1) assign directly the range to your variant variable v - without the Array function. When using the array function, what you are doing is assign an array of one element - consisting of your range returned as an array - to your variable v
2) v will contain a 2 dimensions array:
first dimension will be 1 - for one row returned
second dimension will be as many columns as returned by the range
Then loop through the second dimension of this array - I haven't checked the rest of the code but this should get you on your way