Is there an easier way of importing data into an excel array or other data structure? I've tried researching collections but I have found the documentation hard to comprehend.
http://www.functionx.com/vbaexcel/objects/Lesson6.htm
https://msdn.microsoft.com/en-us/library/f26wd2e5%28v=vs.100%29.aspx
The code I have below opens a select file and searches for the column header and then loops through each row storing the data according to header and row variables, I've done this method for many macros in the past but now I am dealing with many many columns and I'm looking for a more advanced way?
Sub Import_NAVRec()
MyPath = Range("b2") 'Defines cell that contains path to source file
Workbooks.Open (MyPath) 'Opens file
Set tempbook = ActiveWorkbook 'Names workbook
LR = Range("A65000").End(xlUp).Row 'finds last row in sourcefile
ReDim aNavRec(1 To LR, 1 To 4) 'Defines NAV Rec array
nRow = 0
cName = "Accounting Basis"
CA = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
cName = "Accounting Date"
cB = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
cName = "Asset Currency"
cC = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
For r = 2 To LR
'If Cells(r, cB) = "Trading Gain Loss" Then
nRow = nRow + 1
aNavRec(nRow, 1) = Cells(r, CA) 'Fund Number
aNavRec(nRow, 2) = Cells(r, cB) 'Ledger
aNavRec(nRow, 3) = Cells(r, cC) 'Balance change
'End If
Next r
tempbook.Close
End Sub
Sub Print_output()
Sheets("Output").Select
Set Destination = Range("a2")
Destination.Resize(UBound(aNavRec, 1) + 1, UBound(aNavRec, 2)).Value = aNavRec
End Sub
The only thing we can help you eliminate is the for loop in the middle of you code. The rest seems to be necessary.
Option Explicit
Sub Import_NAVRec()
Dim LR As Long
Dim MyPath As String
Dim aNavRec As Variant 'Defines NAV Rec array
Dim tempbook As Workbook
Dim CA As Long, cB As Long, cC As Long
MyPath = Range("B2") 'Defines cell that contains path to source file
Workbooks.Open (MyPath) 'Opens file
Set tempbook = ActiveWorkbook 'Names workbook
LR = Range("A65000").End(xlUp).Row 'finds last row in sourcefile
cName = "Accounting Basis"
CA = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
cName = "Accounting Date"
cB = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
cName = "Asset Currency"
cC = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
aNavRec = Application.Index(Range("A:AZ"), Application.Evaluate("Row(1:" & LR & ")"), Array(CA, cB, cC))
tempbook.Close
End Sub
With Option Explicit some more Dim were necessary (which I included in the above soluion).
Note: just found this solution here: use variable for row_num application.index
Related
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 am using below code to find a phrase "Phase End" in an excel column where the data exists from 1 to 9 phases. Problem is I can find phase 1 to 9 by its " Phase 1" "Phase 2" ... But all phases have the same ending phrases like "Phase End". When I do the search, is it possible to skip the identified phases and continue the search only in the remaining part of the excel column? For example, after identifying "Phase 3" and its "Phase End" I want to continue the search through the values below phase 3 but not before them.
Workbooks(OpenWB).Worksheets("Home").Range("B36") = Cells.Find(What:="Phase 1", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, -1).Value
Workbooks(OpenWB).Worksheets("Home").Range("C36") = Cells.Find(What:="End Phase", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, -1).Value
Workbooks(OpenWB).Worksheets("Home").Range("B37") = Cells.Find(What:="phase 2", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, -1).Value
Workbooks(OpenWB).Worksheets("Home").Range("C37") = Cells.Find(What:="end phase", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, -1).Value
Workbooks(OpenWB).Worksheets("Home").Range("B38") = Cells.Find(What:="phase 3", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, -1).Value
Workbooks(OpenWB).Worksheets("Home").Range("C38") = Cells.Find(What:="end phase", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, -1).Value
I don't know if I understand your question but maybe this will help you out:
Dim StartRow As Integer
Dim EndRng As Range
Dim StartRng As Range
Dim SearchStr As String
Dim i As Integer
Dim NewStartRow As Integer
StartRow = 35
SearchStr = "End Phase"
On Error Resume Next
For i = 1 To 9
NewStartRow = StartRow + i
'Set your own search range here
Set StartRng = Workbooks(OpenWB).Worksheets("Home").Range("B1:B100").Find(What:="Phase " & i)
Workbooks(OpenWB).Worksheets("Home").Range("B" & NewStartRow).Value = Workbooks(OpenWB).Worksheets("Home").Cells(StartRng.Row, StartRng.Column - 1).Value
'Finds the first End Phase and renames it (also edit the range here)
Set EndRng = Workbooks(OpenWB).Worksheets("Home").Range("C1:C100").Find(What:=SearchStr)
Workbooks(OpenWB).Worksheets("Home").Range(EndRng.Address).Value = "End Phase" & i
'Do whatever you want next
Next i
you could try this
Sub main24()
Dim iPhase As Long
Dim afterCell As Range
With Workbooks(OpenWB).Worksheets("Home").UsedRange
Set afterCell = .Cells(.Count) '<--| set it to the last lookedup range for the first iteration so as to have 'Find()' start from the first one
For iPhase = 1 To 9 '<--| iterate through phases
Set afterCell = .Find(What:="Phase " & iPhase, After:=afterCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False) '<--| set 'afterCell' to the found current "Phase" one
.Parent.Range("B36").Offset(iPhase - 1) = afterCell.Offset(0, -1).Value '<--| update corresponding output cell with adjacent value to the left
Set afterCell = .Find(What:="End Phase", After:=afterCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False) '<--| set 'afterCell' to the found current "End Phase" one
.Parent.Range("C36").Offset(iPhase - 1) = afterCell.Offset(, -1).Value '<--| update corresponding output cell with adjacent value to the left
Next
End With
End Sub
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
Right now I am using a horribly inefficient way for a replacement function:
Dim Replacement As String
Dim rngRepVal As Object
Set rngRepVal = Sheets("data").Range(Cells(1, 3), Cells(intRowLast, 3))
Replacement = ActiveCell.Value
rngRepVal.Replace What:="123", Replacement:="ABC", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
rngRepVal.Replace What:="234", Replacement:="ABC", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
rngRepVal.Replace What:="456", Replacement:="DEF", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
... [goes on for 50 lines]
Set rngRepVal = Nothing
I am wondering if this can be achieved with arrays. Something like:
Dim aWhat() As String
Dim aReplacement() As String
aWhat = Split("ABC|DEF|GHI|JKL", "|")
aReplacement = Split(Array("123", 456")|Array("789","1000"), "|") '<-not sure how to organise this
Essentially 123 & 456 get replaced by ABC, 789 & 1000 get replaced by DEF etc. in a replace loop> Any insights on how to organise the two arrays? Thanks!
Your Replace(s) are fine - its the cell by cell loop and selection that is inefficient. Try something like this for three replaces over the entire range at once.
Sub Recut()
Dim rng1 As Range
Set rng1 = Sheets("data").Range(Sheets("data").Cells(1, 3), Sheets("data").Cells(Rows.Count, 3).End(xlUp))
With rng1
.Replace What:="123", Replacement:="ABC", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
.Replace What:="234", Replacement:="ABC", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
.Replace What:="456", Replacement:="DEF", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
End With
End Sub
I would try this:
aWhat=Split("ABC|ABC|DEF|DEF|GHI|GHI...","|")
aReplacement=Split("123|456|789|.....","|")
For i=1 to UBound(aWhat)
rngRepVal.Replace what:=aWhat[i], Replacement:=aReplacement[i], ....
Next i
Just make sure there's the same number of elements in both arrays.
I think found it, by accident:
Dim aOld() As Variant
Dim aNew() As Variant
Dim Group As Variant
Dim Word As Variant
Dim y As Long
aNew = Array("ABC", "DEF", "GHI", "JKL")
aOld = Array(Array("123", "456"), Array("789", "1000"))
With Range("A:A")
For Each Group In aOld
For Each Word In Group
.Replace What:=Word, Replacement:=aNew(y), LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Next
y = y + 1
Next
End With
I got file.txt structure like this:
"FIRST"
a1 b1 c1 d1
a2 b2 c2 c2
"SECOND"
e1 f1
e2 f2
"THIRD"
g1 h1
I got three sheets in my Excel file: "first", "second" and "third". How to populate this data into three sheets by VBA code?
I still think that reading a text file line per line is the best way to go.
You can load the entire file into an array and write conditions later.
Sub Read_text_File()
Dim oFSO As New FileSystemObject
Dim oFS
Dim sText as String
Dim vArray
Dim lCnt as Long
Set oFS = oFSO.OpenTextFile("c:\textfile.TXT")
Do Until oFS.AtEndOfStream
lCnt = lCnt + 1
sText = oFS.ReadLine
vArray(lCnt) = sText
Loop
End Sub
Then look through the array and do your stuff.
Or you could load the data in three separate arrays immediately, representing the three sheets.
This is entirely up to you.
Let me know if this was helpful.
Start recording a macro and open the txt file delimited by space. press ctrl + f and find First, Second and Third in three steps. copy your required range from the active workbook to your required workbook in respective sheets.
this will give you a recorded macro which you can restructure to make an automated code. Maybe i can post some code later. you will have to add lines of vba to read the line numbers of the cells used to find secon and third so that you know what range you have to copy.
1 question, number of columns in your file is as shown????
here is a code.
Sub Macro1()
Dim startRow As Integer
Dim endRow As Integer
Dim wb As Workbook
Workbooks.OpenText Filename:="D:\file.txt", Origin:=437, startRow:=1, _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _
:=True, Tab:=True, Semicolon:=False, Comma:=False, Space:=True, Other _
:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
TrailingMinusNumbers:=True
Set wb = ActiveWorkbook
Cells.Find(What:="FIRST", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
startRow = ActiveCell.Row + 1
Cells.Find(What:="SECOND", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
endRow = ActiveCell.Row - 1
Range("A" & startRow & ":D" & endRow).Copy
ThisWorkbook.Activate
Sheets("Sheet1").Select
Range("A1").Select
ActiveSheet.Paste
startRow = endRow + 2
wb.Activate
Cells.Find(What:="THIRD", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
endRow = ActiveCell.Row - 1
Range("A" & startRow & ":D" & endRow).Copy
ThisWorkbook.Activate
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
wb.Activate
startRow = endRow + 2
endRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & startRow & ":D" & endRow).Copy
ThisWorkbook.Activate
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
wb.Close (False)
End Sub