This program removes a string from an array to a new sheet. I find the string 'hello' or 'bye' but I also want the string in the index before each of those strings. The string before 'hello' or 'bye' will not always be the same so how can the I use the Index() function?
Sub SplitWithFormat()
Dim R As Range, C As Range
Dim i As Long, V As Variant
Dim varHorizArray As Variant
Dim rge As Range
Dim intCol As Integer
Set R = Range("d1", Cells(Rows.Count, "d").End(xlUp))
For Each C In R
With C
.TextToColumns Destination:=.Range("AD1"), DataType:=xlDelimited, _
consecutivedelimiter:=True, Tab:=False, semicolon:=True, comma:=False, _
Space:=True, other:=True, Otherchar:=vbLf
Set rge = Selection
varHorizArray = rge
.Copy
Range(.Range("AD1"), Cells(.Row, Columns.Count).End(xlToLeft)).PasteSpecial xlPasteFormats
End With
Next C
Application.CutCopyMode = False
For intCol = LBound(varHorizArray, 2) To UBound(varHorizArray, 2)
Debug.Print varHorizArray(1, intCol)
Next intCol
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
varHorizArray = Array("bye","hello")
Set NewSh = Worksheets.Add
With Sheets("Sheet2").Range("AD1:AZ100")
Rcount = 0
For i = LBound(varHorizArray) To UBound(varHorizArray)
Set Rng = .find(What:=varHorizArray(i), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1
Rng.Copy NewSh.Range("A" & Rcount)
NewSh.Range("A" & Rcount).Value = Rng.Value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next i
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
While the InStr function is typically used to locate a substring within a string, your multiple search terms may be better handled with the Split function.
Option Explicit
Sub stripName()
Dim rw As Long
With ActiveSheet
For rw = 1 To .Cells(Rows.Count, "D").End(xlUp).Row
.Cells(rw, "A") = Split(Split(.Cells(rw, "D").Value2, ", hello")(0), ", bye")(0)
Next rw
End With
End Sub
Note that the search terms use on the split are case-sensitive.
Addendum for revised question:
Option Explicit
Sub stripName()
Dim rw As Long, s As String
With ActiveSheet
For rw = 1 To .Cells(Rows.Count, "D").End(xlUp).Row
s = Split(.Cells(rw, "D").Value2, ", bye")(0)
s = Split(s, ", hello")(0)
s = Split(Chr(32) & s, Chr(32))(UBound(Split(Chr(32) & s, Chr(32))))
.Cells(rw, "A") = s
Next rw
End With
End Sub
Related
I want a cod that will find duplicates and return it in separate array.
So I found a code that would be perfect for me, but the thing is that this code is removing duplicates. I thought that it will be a simple job to change it, but somehow I cannot manage to do it....
I was thinking that it will be in this part of code If Err.Number <> 0 Then coll.Remove txt but have no idea how to change it. I have tried changing <> with = but it seems not to work.
Can someone tell me where and how should I change the code to get duplicates from 2 arrays.
Sub test()
Dim arr1 As Variant
Dim arr2 As Variant
Dim arr3 As Variant
Dim coll As Collection
Dim I As Long, j As Long, ii As Long, txt As String, x
With Worksheets("Sheet1")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr1 = .Range("A2:C" & LastRowColumnA).Value
End With
With Worksheets("Sheet2")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr2 = .Range("A2:C" & LastRowColumnA).Value
End With
Set coll = New Collection
On Error Resume Next
For I = LBound(arr1, 1) To UBound(arr1, 1)
txt = Join(Array(arr1(I, 1), arr1(I, 2), arr1(I, 3)), Chr(2))
coll.Add txt, txt
Next I
For I = LBound(arr2, 1) To UBound(arr2, 1)
txt = Join(Array(arr2(I, 1), arr2(I, 2), arr2(I, 3)), Chr(2))
Err.Clear
coll.Add txt, txt
If Err.Number <> 0 Then coll.Remove txt
Next I
ReDim arr3(1 To coll.Count, 1 To 3)
For I = 1 To coll.Count
x = Split(coll(I), Chr(2))
For ii = 0 To 2
arr3(I, ii + 1) = x(ii)
Next
Next I
Worksheets("test").Range("A2").Resize(UBound(arr3, 1), 3).Value = arr3
Columns("A:C").EntireColumn.AutoFit
End Sub
Regards,
Timonek
Extract Duplicates
If you set CountSameWorksheetDuplicates to True, it will return the duplicates of each worksheet even if they are not found in the other worksheet.
Option Explicit
Sub ExtractDuplicates()
Const sName1 As String = "Sheet1"
Const sCols1 As String = "A:C"
Const sfRow1 As Long = 2
Const sName2 As String = "Sheet2"
Const sCols2 As String = "A:C"
Const sfRow2 As Long = 2
Const dName As String = "Test"
Const dfCellAddress As String = "A2"
Const CountSameWorksheetDuplicates As Boolean = False
Dim Delimiter As String: Delimiter = Chr(2)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sData As Variant
sData = RefColumns(wb.Worksheets(sName1).Rows(sfRow1).Columns(sCols1))
Dim cCount As Long: cCount = UBound(sData, 2)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
Dim sKey As Variant
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
If CountSameWorksheetDuplicates Then
DictAddCount dict, sKey
Else
DictAdd dict, sKey, 1
End If
Next r
sData = RefColumns(wb.Worksheets(sName2).Rows(sfRow2).Columns(sCols2))
If CountSameWorksheetDuplicates Then
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAddCount dict, sKey
Next r
Else
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
dict2.CompareMode = vbTextCompare
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAdd dict2, sKey
Next r
For Each sKey In dict2.Keys
DictAddCount dict, sKey
Next sKey
Set dict2 = Nothing
End If
Erase sData
For Each sKey In dict.Keys
If dict(sKey) = 1 Then dict.Remove sKey
Next sKey
Dim drCount As Long: drCount = dict.Count
If drCount = 0 Then Exit Sub
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
r = 0
Dim c As Long
For Each sKey In dict.Keys
sData = Split(sKey, Delimiter)
r = r + 1
For c = 1 To cCount
dData(r, c) = sData(c - 1)
Next c
Next sKey
Dim drg As Range
Set drg = wb.Worksheets(dName).Range(dfCellAddress).Resize(drCount, cCount)
drg.Value = dData
drg.Resize(drg.Worksheet.Rows.Count - drg.Row - drCount + 1) _
.Offset(drCount).Clear ' clear below
drg.EntireColumn.AutoFit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range from the first row of a range
' ('FirstRowRange') to the row range containing
' the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
ByVal FirstRowRange As Range) _
As Range
If FirstRowRange Is Nothing Then Exit Function
With FirstRowRange.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 row of a 2D array in a delimited string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function StrJoinedDataRow( _
ByVal Data As Variant, _
ByVal RowIndex As Long, _
Optional ByVal Delimiter As String = " ") _
As String
Const ProcName As String = "StrJoinedDataRow"
On Error GoTo ClearError
Dim c As Long
Dim cString As String
For c = LBound(Data, 2) To UBound(Data, 2)
cString = cString & CStr(Data(RowIndex, c)) & Delimiter
Next c
StrJoinedDataRow = Left(cString, Len(cString) - Len(Delimiter))
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') adding another value ('Item')
' to the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAdd( _
ByRef dict As Object, _
ByVal Key As Variant, _
Optional ByVal Item As Variant = Empty)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Item
End If
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') increasing its count being held
' in the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddCount( _
ByRef dict As Object, _
ByVal Key As Variant)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = dict(Key) + 1
End If
End If
End Sub
Dim Dict as Object
Dict = CreateObject("Scripting.Dictionary")
Dim Line As Object
For Each line in MyArray
On Error Resume Next
Dict.Add(Line, "")
On Error Goto 0
Next
Dictionaries don't allow duplicate keys. We are only setting keys and ignoring the value by not setting it. The dictionary raises an error if the key exists.
I have several excel sheets with tables with a similar format to below:
Where I'd like to copy all the rows where the number under the "Value" header exceeds 10 into a blank tab.
Sub Copy_Criteria()
With Range("A5:P1000")
.AutoFilter Field:=15, Criteria1:=">10"
End With
End Sub
After that I would like to select all the values filtered here and copy them into a blank sheet. Next I'd like to repeat the whole process, but copying the rows based on another header/criteria into a second blank tab.
Thanks!
You can do something like this:
With Range("A5:P1000")
.AutoFilter Field:=15, Criteria1:=">30"
On Error Resume Next 'in case no visible cells
.SpecialCells(xlCellTypeVisible).Copy Sheet2.Range("a1")
On Error Goto 0
.Parent.ShowAllData 'clear filter
End With
Copy By Criteria
Adjust the values in the constants section.
Option Explicit
Sub CopyByCriteria()
' Needs 'RefCurrentRegionBottomRight', 'GetFilteredRange' and 'GetRange'.
Const ProcTitle As String = "CopyByCriteria"
Const sFirst As String = "A5"
Dim swsNames As Variant: swsNames = Array("Sheet1", "Sheet2", "Sheet3")
Const dFirst As String = "A1"
' These three arrays need to have the same number of elements.
Dim dwsNames As Variant: dwsNames = Array("15gt10", "12gt15")
Dim dFields As Variant: dFields = Array(15, 12)
Dim dCriteria As Variant: dCriteria = Array(">10", ">15")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet
Dim srg As Range
Dim dws As Worksheet
Dim drg As Range
Dim dCell As Range
Dim dData As Variant
Dim n As Long
Dim IncludeHeaders As Boolean
For n = LBound(dwsNames) To UBound(dwsNames)
On Error Resume Next
Application.DisplayAlerts = False
wb.Sheets(dwsNames(n)).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dwsNames(n)
Set dCell = dws.Range(dFirst)
IncludeHeaders = True
For Each sws In wb.Worksheets(swsNames)
Set srg = RefCurrentRegionBottomRight(sws.Range(sFirst))
dData = GetFilteredRange( _
srg, dFields(n), dCriteria(n), IncludeHeaders, IncludeHeaders)
If Not IsEmpty(dData) Then
IncludeHeaders = False ' include only the first time
Set drg = dCell.Resize(UBound(dData, 1), UBound(dData, 2))
drg.Value = dData
Set dCell = dCell.Offset(UBound(dData, 1))
End If
Next sws
Next n
MsgBox "Worksheets created. Values copied.", vbInformation, ProcTitle
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the filtered values of a range ('rg')
' in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFilteredRange( _
ByVal rg As Range, _
ByVal fField As Long, _
ByVal fCriteria As String, _
Optional ByVal IncludeHeaders As Boolean = True, _
Optional ByVal AllowHeadersOnly As Boolean = False) _
As Variant
' Needs the 'GetRange' function.
Const ProcName As String = "GetFilteredRange"
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = rg.Worksheet
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
rg.AutoFilter fField, fCriteria
Dim frShift As Long: frShift = IIf(IncludeHeaders, 0, 1)
Dim frg As Range
On Error Resume Next
Set frg = rg.Resize(rg.Rows.Count - frShift) _
.Offset(frShift).SpecialCells(xlCellTypeVisible)
On Error GoTo ClearError
ws.AutoFilterMode = False
If Not frg Is Nothing Then
Dim frCount As Long
frCount = Intersect(frg, ws.Columns(frg.Column)).Cells.Count
Dim doContinue As Boolean: doContinue = True
If frShift = 0 Then
If frCount = 1 Then
If Not AllowHeadersOnly Then
doContinue = False
End If
End If
End If
If doContinue Then
Dim fcCount As Long: fcCount = frg.Columns.Count
Dim dData As Variant: ReDim dData(1 To frCount, 1 To fcCount)
Dim tData As Variant
Dim arg As Range
Dim ar As Long
Dim c As Long
Dim dr As Long
Dim trCount As Long
For Each arg In frg.Areas
tData = GetRange(arg)
For ar = 1 To arg.Rows.Count
dr = dr + 1
For c = 1 To fcCount
dData(dr, c) = tData(ar, c)
Next c
Next ar
Next arg
GetFilteredRange = dData
'Else ' frShift = 0: frCount = 1: AllowHeadersOnly = False
End If
'Else ' no filtered range
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range starting with a given cell
' and ending with the last cell of its Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegionBottomRight( _
ByVal FirstCellRange As Range) _
As Range
If FirstCellRange Is Nothing Then Exit Function
With FirstCellRange.Cells(1).CurrentRegion
Set RefCurrentRegionBottomRight = _
FirstCellRange.Resize(.Row + .Rows.Count - FirstCellRange.Row, _
.Column + .Columns.Count - FirstCellRange.Column)
End With
End Function
I am running into an issue with my current code - I am hoping someone can assist:
Issue: I am trying to do a Vlookup from Workbook "ABC". The issue is, I am trying to change the VLOOKUP Col_Index_Number based on a header on workbook ABC...
So for example: For MyArray "Food" I am looking to Vlookup Column_Index_Num for "Food-Mexican" Column on workbook ABC, For MyArray Appetizers, I am looking to Vlookup Column_Index-Num for "Appetizers-American"...
Additionally, the columns will not always be in the same place for each report so it has to be based on the row 1 header of ABC workbook.
Also, sometimes the Array iteration might be skipped, if say for example, "Non-AlcoholicDrinks" is not found.
Sub WIP()
Dim wb As Workbook
Dim wsMain As Worksheet
Dim wsLookup As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim rFind1 As Range
Dim rFind2 As Range
Dim rFind3 As Range
Dim MyArray As Variant
Dim LookupHeaders As Variant
Dim LookupHeaders2 As Variant
Dim LR As Long
Dim i As Long
Dim PriceCol As Long
Dim pricecol2 As Long
Dim LastColumn As Long
Dim LastColumn2 As Long
Dim LastColumn3 As Long
Dim LastColumn4 As Long
Dim IndexCol As Long
'Unformatted Price Row
Sheets("Consolidate List").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("J:N").Delete
Columns("J:J").Select
ActiveWindow.FreezePanes = True
Range("H2").Select
ActiveCell.FormulaR1C1 = "New Price"
ActiveCell.Interior.ColorIndex = 22
Range("H3:H" & LR).Formula = "=VLOOKUP(RC[-7],'Connect Report'!C[-7]:C[-6],2,FALSE)"
ActiveCell.EntireColumn.Resize(Rows.Count - 2).Offset(2).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("I2").Select
ActiveCell.FormulaR1C1 = "Difference"
ActiveCell.Interior.ColorIndex = 22
Range("I3:I" & LR).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"
ActiveCell.EntireColumn.Resize(Rows.Count - 2).Offset(2).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Set wb = ActiveWorkbook
Sheets("Consolidate List").Select
Set wsMain = wb.ActiveSheet
Set wsLookup = wb.Sheets("Connect Report") '<-- Change to correct sheet name for the Lookup sheet
LR = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
MyArray = Array("US", "SPAIN", "California")
LookupHeaders = Array("TTIER", "Time333", "Round6")
LookupHeaders2 = Array("TELLER5", "Fly7", "Mine4")
For i = LBound(MyArray) To UBound(MyArray)
With wsMain.Rows(1)
Set rFind1 = .Find(What:=MyArray(i), LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind1 Is Nothing Then
Set rng = rFind1.Offset(1).Resize(, 8)
PriceCol = Application.Match("New Opposed Price", rng, 0)
LastColumn = rFind1.Column + PriceCol
If wsMain.Cells(rng.Row, LastColumn) <> "New Opposed Price" Then
wsMain.Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsMain.Cells(rng.Row, LastColumn).Value = "New Opposed Price"
wsMain.Cells(rng.Row, LastColumn).Interior.ColorIndex = 22
LastColumn2 = LastColumn + 1
wsMain.Columns(LastColumn2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsMain.Cells(rng.Row, LastColumn2).Value = "Difference"
wsMain.Cells(rng.Row, LastColumn2).Interior.ColorIndex = 22
Set rFind2 = wsLookup.Rows(1).Find(LookupHeaders(i), wsLookup.Range("A1"), xlValues, xlWhole)
If Not rFind2 Is Nothing Then
IndexCol = rFind2.Column
wsMain.Cells(rng.Row + 1, LastColumn).Resize(LR - 2).Formula = "=VLOOKUP(A" & rng.Row + 1 & ",'Connect Report'!$A:$AL," & IndexCol & ",FALSE)"
wsMain.Cells(rng.Row + 1, LastColumn2).Resize(LR - 2).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"
Else
MsgBox "Excel could not find " & LookupHeaders(i) & " in the lookup table."
End If
Set rng2 = rFind1.Offset(1).Resize(, 8)
pricecol2 = Application.Match("New Muted Price", rng, 0)
LastColumn3 = rFind1.Column + pricecol2
If wsMain.Cells(rng.Row, LastColumn3) <> "New Muted Price" Then
wsMain.Columns(LastColumn3).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsMain.Cells(rng2.Row, LastColumn3).Value = "New Muted Price"
wsMain.Cells(rng2.Row, LastColumn3).Interior.ColorIndex = 22
LastColumn4 = LastColumn3 + 1
wsMain.Columns(LastColumn4).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsMain.Cells(rng2.Row, LastColumn4).Value = "Difference"
wsMain.Cells(rng2.Row, LastColumn4).Interior.ColorIndex = 22
End If
Set rFind3 = wsLookup.Rows(1).Find(LookupHeaders2(i), wsLookup.Range("A1"), xlValues, xlWhole)
If Not rFind3 Is Nothing Then
IndexCol = rFind3.Column
wsMain.Cells(rng2.Row + 1, LastColumn3).Resize(LR - 2).Formula = "=VLOOKUP(A" & rng2.Row + 1 & ",'Connect Report'!$A:$AL," & IndexCol & ",FALSE)"
wsMain.Cells(rng2.Row + 1, LastColumn4).Resize(LR - 2).Formula = "=IF(OR(OR(RC[-2]="""",RC[-1]="""",RC[-1]=""x"",)),"""",RC[-1]-RC[-2])"
Else
MsgBox "Excel could not find " & LookupHeaders2(i) & " in the lookup table."
End If
End If
End If
End With
Next i
End Sub
Can anyone help with this? I am completely lost on how to resolve this issue. Also, I am hoping that I described the issue clearly... it is quite confusing.
I believe something like this should work for you. Give it a try and let me know.
Sub tgr()
Dim wb As Workbook
Dim wsMain As Worksheet
Dim wsLookup As Worksheet
Dim rng As Range
Dim rFind1 As Range
Dim rFind2 As Range
Dim MyArray As Variant
Dim LookupHeaders As Variant
Dim LR As Long
Dim i As Long
Dim PriceCol As Long
Dim LastColumn As Long
Set wb = ActiveWorkbook
Set wsMain = wb.ActiveSheet
Set wsLookup = wb.Sheets("ABC") '<-- Change to correct sheet name for the Lookup sheet
LR = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
MyArray = Array("TEST", "Food", "Non-AlcoholicDrinks", "Appetizers", "Alcoholic Drinks")
LookupHeaders = Array("TestHeader", "FoodHeader", "Non-AlcoholicDrinksHeader", "AppetizersHeader", "Alcoholic DrinksHeader")
For i = LBound(MyArray) To UBound(MyArray)
Set rFind1 = wsMain.Rows(1).Find(What:=MyArray(i), LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind1 Is Nothing Then
Set rng = rFind1.Offset(1).Resize(, 8)
PriceCol = Application.Match("Price", rng, 0)
LastColumn = rFind1.Column + PriceCol
If wsMain.Cells(rng.Row, LastColumn) <> "Difference" Then
wsMain.Columns(LastColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wsMain.Cells(rng.Row, LastColumn).Value = "Difference"
wsMain.Cells(rng.Row, LastColumn).Interior.ColorIndex = 22
End If
Set rFind2 = wsLookup.Rows(1).Find(LookupHeaders(i), wsLookup.Range("A1"), xlValues, xlPart)
If Not rFind2 Is Nothing Then
With wsMain.Cells(rng.Row + 1, LastColumn).Resize(LR - 2)
.Formula = "=VLOOKUP(A" & rng.Row + 1 & "," & wsLookup.Range("A:AL").Address(External:=True) & "," & rFind2.Column & ",FALSE)"
.Value = .Value 'Convert to values
End With
End If
End If
Next i
End Sub
This is a User Defined Function I've wrote to find the range of based on column header, it uses .find method to find the target cells. Works well if you column titles are are the top of your worksheet.
I hope this solves your problem, you could just findout the target column, by using .column on the range returned.
'define a range by looking for a specific text title, and return all the cells to the lastrow of the sheet as a range
Private Function defineColRange(ByVal targetWorkSheet As Worksheet, ByVal targetValue As String, _
Optional ByVal visibleOnly As Boolean, Optional ByVal rtnNoTitle As Boolean, _
Optional ByVal searchByColumn, Optional ByVal searchBackwards) As Range
Dim targetlastRow As Long
Dim targetlastCol As Long
Dim returnRange As Range
Dim findTarget As Range
'default visible only mode off
If IsMissing(visibleOnly) Then
visibleOnly = False
End If
If IsMissing(rtnNoTitle) Then 'Don't return title cell in the range returned
rtnNoTitle = False
End If
If IsMissing(searchByColumn) Then 'Search vertically by column, instead of by rows
searchByColumn = False
End If
If IsMissing(searchBackwards) Then 'Search backwards by rows
searchBackwards = False
End If
'test if targetWorkSheet is not empty
If targetWorkSheet Is Nothing Then
MsgBox ("Worksheet pass failed!"), vbExclamation
Exit Function
End If
targetWorkSheet.Activate
targetlastRow = targetWorkSheet.UsedRange.Find(What:="*", _
after:=Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
Searchorder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
targetlastCol = targetWorkSheet.UsedRange.Find(What:="*", _
after:=Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
Searchorder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'find the range
If searchByColumn = True Then
Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
ElseIf searchBackwards = True Then
Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, targetlastCol), _
LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False)
Else
Set findTarget = targetWorkSheet.UsedRange.Find(What:=targetValue, after:=Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlPart, Searchorder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
End If
If findTarget Is Nothing Then
Debug.Print ("Did not find columne title """ & targetValue & ""), vbExclamation
Exit Function
Else
Dim tRow, tCol As Long
tRow = findTarget.Row
tCol = findTarget.Column
On Error Resume Next
If visibleOnly = False Then
If rtnNoTitle = False Then
Set returnRange = targetWorkSheet.Range(Cells(tRow, tCol), Cells(targetlastRow, tCol))
Set defineColRange = returnRange
Else
Set returnRange = targetWorkSheet.Range(Cells(tRow + 1, tCol), Cells(targetlastRow, tCol))
Set defineColRange = returnRange
End If
Else
If rtnNoTitle = False Then
Set returnRange = targetWorkSheet.Range(Cells(tRow, tCol), Cells(targetlastRow, tCol)).SpecialCells(xlCellTypeVisible)
Set defineColRange = returnRange
Else
Set returnRange = targetWorkSheet.Range(Cells(tRow + 1, tCol), Cells(targetlastRow, tCol)).SpecialCells(xlCellTypeVisible)
Set defineColRange = returnRange
End If
End If
If Err <> 0 Then
Debug.Print "Worksheet: " & targetWorkSheet.Name & " Column Name: " & targetValue
End If
On Error GoTo 0
Err.Clear
End If
End Function
I want to optimize the following code, as it is very slow.
I am using the code found in this answer:
https://stackoverflow.com/a/27108055/1042624
However, it is very slow when looping through +10k rows. Is it possible to optimize my code below? I have tried to modify it a bit, but it does not seem to work.
Sub DeleteCopy2()
Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
Dim strSheetName As String
Dim arrVal() As Long
Application.ScreenUpdating = False
Application.Calculation = xlManual
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row
DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row
ReDim arrVal(2 To LastRow) ' Headers in row 1
For CurRow = LBound(arrVal) To UBound(arrVal)
If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("MatchData").Range("A" & CurRow).Value = ""
Else
End If
Next CurRow
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Can you try this for me? I have commented the code so that you will not have a problem understanding it. Also check how much time it takes for 10k+ rows
Logic
Store search values in array 1
Store destination values in array 2
Loop through the first array and check if it is present in the second array. If present, clear it
Clear the search values from sheet1
Output the array to the sheet1
Sort Col A so that the blanks go down.
Code
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long, i As Long
Dim MArr As Variant, DArr As Variant
Dim strSheetName As String
Dim rng As Range
strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A2:A" & lRow)
MArr = rng.Value
End With
'~~> Store destination values in the 2nd array
With wbDestSheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
DArr = .Range("A2:A" & lRow).Value
End With
'~~> Check if the values are in the other array
For i = LBound(MArr) To UBound(MArr)
If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = ""
Next i
With wbMatch
'~~> Clear the range for new output
rng.ClearContents
'~~> Output the array to the worksheet
.Range("A2").Resize(UBound(MArr), 1).Value = MArr
'~~> Sort it so that the blanks go down
.Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
End Sub
'~~> function to check is a value is in another array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim j As Long
For j = 1 To UBound(arr, 1)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Function
Edit
Another way. Based on the sample file, this code runs in approx 1 minute.
Start : 8/4/2016 08:59:36 PM
End : 8/4/2016 09:00:47 PM
Logic:
It uses CountIf to check for duplicates and then deletes the duplicates using .Autofilter
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long
Dim strSheetName As String
Dim rng As Range
Debug.Print "Start : " & Now
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns(2).Insert
Set rng = .Range("B2:B" & lRow)
lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row
rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)"
DoEvents
rng.Value = rng.Value
.Range("B1").Value = "Temp"
'Remove any filters
.AutoFilterMode = False
With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows
.AutoFilter Field:=2, Criteria1:=">0"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'Remove any filters
.AutoFilterMode = False
.Columns(2).Delete
End With
Debug.Print "End : " & Now
End Sub
Looks like #SiddarthRout and I were working in parallel...
My code example below executes in less than 2 secs (eyeball estimate) over almost 12,000 rows.
Option Explicit
Sub DeleteCopy2()
Dim codeTimer As CTimer
Set codeTimer = New CTimer
codeTimer.StartCounter
Dim thisWB As Workbook
Dim destSH As Worksheet
Dim matchSH As Worksheet
Set thisWB = ThisWorkbook
Set destSH = thisWB.Sheets("Week 32")
Set matchSH = thisWB.Sheets("MatchData")
Dim lastMatchRow As Long
Dim lastDestRow As Long
lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
'--- copy working data into memory arrays
Dim destArea As Range
Dim matchData As Variant
Dim destData As Variant
matchData = matchSH.Range("A1").Resize(lastMatchRow, 1)
Set destArea = destSH.Range("A1").Resize(lastDestRow, 1)
destData = destArea
Dim i As Long
For i = 2 To lastDestRow
If Not InMatchingData(matchData, destData(i, 1)) Then
destData(i, 1) = ""
End If
Next i
'--- write the marked up data back to the worksheet
destArea = destData
Debug.Print "Destination rows = " & lastDestRow
Debug.Print "Matching rows = " & lastMatchRow
Debug.Print "Execution time = " & codeTimer.TimeElapsed & " secs"
End Sub
Private Function InMatchingData(ByRef dataArr As Variant, _
ByRef dataVal As Variant) As Boolean
Dim i As Long
InMatchingData = False
For i = LBound(dataArr) To UBound(dataArr)
If dataVal = dataArr(i, 1) Then
InMatchingData = True
Exit For
End If
Next i
End Function
The timing results from my code are (using the timer class from this post ):
Destination rows = 35773
Matching rows = 23848
Execution time = 36128.4913359179 secs
The code below break the cells in image 1 into an array pictured in image 2. The new array is moved to start at AG. After that the program looks through the array and finds the words 'hello' and 'bye'. It takes those words and moves them into a new sheet and column pictured in image 3. Where I'm having trouble is that I want to still pull the strings 'hello' and 'bye' but I want to also pull the string directly before it from the array. In my example (image 3) I would've wanted it to read 'John Hello' instead of 'hello' on its own. What function would I use to extract the string before 'hello' or 'bye' also from the array?
Sub SplitWithFormat()
Dim R As Range, C As Range
Dim i As Long, V As Variant
Dim varHorizArray As Variant
Dim rge As Range
Dim intCol As Integer
Dim s As String
Set R = Range("d1", Cells(Rows.Count, "d").End(xlUp))
For Each C In R
With C
.TextToColumns Destination:=.Range("AD1"), DataType:=xlDelimited, _
consecutivedelimiter:=True, Tab:=False, semicolon:=True, comma:=False, _
Space:=True, other:=True, Otherchar:=vbLf
Set rge = Selection
varHorizArray = rge
.Copy
Range(.Range("AD1"), Cells(.Row, Columns.Count).End(xlToLeft)).PasteSpecial xlPasteFormats
End With
Next C
Application.CutCopyMode = False
For intCol = LBound(varHorizArray, 2) To UBound(varHorizArray, 2)
Debug.Print varHorizArray(1, intCol)
Next intCol
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
varHorizArray = Array("hello", "bye")
Set NewSh = Worksheets.Add
With Sheets("Sheet2").Range("AD1:AZ100")
Rcount = 0
For i = LBound(varHorizArray) To UBound(varHorizArray)
Set Rng = .find(What:=varHorizArray(i), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1
Rng.Copy NewSh.Range("A" & Rcount)
NewSh.Range("A" & Rcount).Value = Rng.Value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next i
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Option Explicit
Sub Tester()
Dim c As Range, v As String, arr, x As Long, e
Dim d As Range
'EDIT: changed destination for results
Set d = WorkSheets("Sheet2").Range("D2") '<<results start here
For Each c In ActiveSheet.Range("A2:A10")
v = Trim(c.Value)
If Len(v) > 0 Then
'normalize other separators to spaces
v = Replace(v, vbLf, " ")
'remove double spaces
Do While InStr(v, " ") > 0
v = Replace(v, " ", " ")
Loop
'split to array
arr = Split(v, " ")
For x = LBound(arr) To UBound(arr)
e = arr(x)
'see if array element is a word of interest
If Not IsError(Application.Match(LCase(e), Array("hello", "bye"), 0)) Then
If x > LBound(arr) Then
d.Value = arr(x - 1) & " " & e 'prepend previous word
Else
d.Value = "??? " & e 'no previous word
End If
Set d = d.Offset(1, 0)
End If
Next x
End If
Next c
End Sub
Something like this?
Option Explicit
Sub strings()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim lookingForThese() As String
Set ws = ThisWorkbook.Worksheets(1)
Set rng = ws.Range(ws.Range("A1"), ws.Range("A1").End(xlDown))
ReDim lookingForThese(1 To 2)
lookingForThese(1) = "bye"
lookingForThese(2) = "hello"
For Each cell In rng
Dim i As Integer
Dim parts() As String
'Split the string in the cell
parts = Split(cell.Value, " ")
'I'm parsing the parts to a 2. worksheet and the hello/bye + the word before those on a 3.
For i = LBound(parts) To UBound(parts)
Dim j As Integer
ThisWorkbook.Worksheets(2).Cells(cell.Row, i + 1).Value = parts(i)
For j = LBound(lookingForThese) To UBound(lookingForThese)
If parts(i) = lookingForThese(j) Then
If i <> LBound(parts) Then
ThisWorkbook.Worksheets(3).Cells(cell.Row, 1).Value = parts(i - 1) & " " & parts(i)
Else
ThisWorkbook.Worksheets(3).Cells(cell.Row, 1).Value = parts(i)
End If
End If
Next j
Next i
Next cell
End Sub