I have a file that I would like to run a Find and Replace on using data from another Excel file.
I have this so far, what am I doing wrong?
Sub LegalName()
Dim NameListWB As Workbook
Dim NameListWS As Worksheet
Set NameListWB = Workbooks.Open("File.xlsx")
Set NameListWS = NameListWB.Worksheets("Sheet1")
Dim rng As Range
Set rng = NameListWS.Range("A:B").Select
Do Until IsEmpty(ActiveCell)
Worksheets("Sheet1").Columns("F").Replace _
What:=ActiveCell.Value, Replacement:=ActiveCell.Offset(0, 1).Value, _
SearchOrder:=xlByColumns, MatchCase:=False
ActiveCell.Offset(1, 0).Select
Loop
End Sub
I see that you started by declaring your objects but missed out on few. Also, you need to avoid the use of .Select Interesting Read
Is this what you are trying (UNTESTED)?
Sub Sample()
Dim NameListWB As Workbook, thisWb As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet
Dim i As Long, lRow As Long
'~~> This is the workbook from where your code is running
Set thisWb = ThisWorkbook
'~~> Change this to the sheet name where you want to replace
'~~> in Column F
Set thisWs = thisWb.Sheets("Sheet1")
'~~> File.xlsx
Set NameListWB = Workbooks.Open("C:\File.xlsx")
Set NameListWS = NameListWB.Worksheets("Sheet1")
With NameListWS
'~~> Find last row in Col A of File.xlsx
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop though Col A
For i = 1 To lRow
'~~> Do the replace
thisWs.Columns(6).Replace What:=.Range("A" & i).Value, _
Replacement:=.Range("B" & i).Value, _
SearchOrder:=xlByColumns, _
MatchCase:=False
Next i
End With
End Sub
Related
I have been working on a small macro but have run into an error.
The function of the macro is as follows: There is a list of stocks in an existing sheet. The macro goes into the folders and opens a spreadsheet where the recommendations are stored. It then goes back to the original sheet, takes each stock code and then goes into the recommendations sheet to see if there is a corresponding stock and what its recommendation is.
The code works fine, however I am now getting a VBA run-time error 438 when I am trying to get the macro to switch which workbook it needs to work on.
The error occurs on the lines application.wb2.activate and then lower down again with application.wb2.activate and application.wb.activate
When I replace wb and wb2 with the full directory, i.e. H:\A\AA\recommendations.xlsx and H:\A\AA\november 2017.xlsm, it works fine.
Would appreciate any help here! Thanks!
Option Explicit
Option Compare Text
Sub gsr()
Dim firstrow As Integer, lastrow As Integer, i As Integer
Dim gsr As Range, msr As Range
Dim stock, findstock As Range, col As Integer
Dim sPath As String, sFile As String
Dim sPath2 As String, sFile2 As String
Dim wb As Workbook, wb2 As Workbook
Dim xlrange As Range, xlcell As Range, xlsheet As Worksheet
Dim xllastrow As Integer
Dim foundlocationG As String, foundlocationM As String
With ActiveWorkbook
sPath2 = ActiveWorkbook.Path & "\"
sFile2 = sPath2 & ActiveWorkbook.Name
Set wb2 = ActiveWorkbook
End With
sPath = "H:\A\AA\"
sFile = sPath & "Recommendations.xlsx"
Set wb = Workbooks.Open(sFile)
Set xlsheet = Sheets("Sheet1")
xllastrow = xlsheet.Range("A1").End(xlDown).Row
Set xlrange = xlsheet.Range("A1:A" & xllastrow)
Application.wb2.Activate
With wb2.Sheets("Sheet1").Range("A:Z")
Set stock = .Find(what:="Stock", After:=.Cells(.Cells.Count), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
Set gsr = .Find(what:="GS", After:=.Cells(.Cells.Count), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
Set msr = .Find(what:="MS", After:=.Cells(.Cells.Count), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
firstrow = stock.Row + 1
lastrow = .Cells(.Rows.Count, stock.Column).End(xlUp).Row
lastrow = lastrow - 1
col = stock.Column
For i = firstrow To lastrow
For Each xlcell In xlrange
If xlcell.Value = Cells(i, col) Then
Application.wb.Activate
foundlocationG = Cells(xlcell.Row, 2)
foundlocationM = Cells(xlcell.Row, 3)
Application.wb2.Activate
Cells(i, gsr.Column) = foundlocationG
Cells(i, msr.Column) = foundlocationM
End If
Next xlcell
Next i
End With
End Sub
You seem to be confusing the Workbook.Activate and Application.Activate¹ methods.
Activate is a direct method of the Workbook object. If you have correctly assigned (e.g. Set) an object-level variable to the Workbook object, you should be able to call the Activate method directly.
Solution: drop the Application and simply Activate the open workbook from the assigned object variable.
wb2.Activate
...
wb.Activate
For all intents and purposes, activating the workbooks as you have done is not necessary and is not the more efficient code. See How to avoid using Select in Excel VBA for more information.
¹ Application.Activate is more commonly used within Word VBA projects.
I want to copy and paste from one excel to another using copy and paste visible cells only as I have a filtered table between a set range.
I'd like to do this through save CSV but apparently this is not possible. The code below works but it doesn't seem to copy paste visible cells/filtered cells like I'd like.
Thanks in advance. Or if there's another recommended way for getting filtered tables to a CSV I'd love to hear how. Cheers.
Sub Macro2()
'
' Macro2 Macro
'
'
Dim lastRow As Long
Dim ws As Worksheet, tbl As ListObject
Set ws = Sheets("Sheet1")
Set tbl = ws.ListObjects("Table1")
With tbl.ListColumns(3).Range
lastRow = .Find(What:="*", _
After:=.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Sheet1.Range("A2").SpecialCells(xlCellTypeVisible).Copy _
Destination:=Range("A2")
ActiveWorkbook.SaveAs Filename:="C:\Users\teaz\Videos\CSV", FileFormat:= _
xlCSV, CreateBackup:=False
ActiveWorkbook.SaveCopyAs Filename:="C:\Users\teaz\Videos" & Test1Str & " " & TestStr & " " & ActiveWorkbook.Name
Application.ActiveWindow.Close SaveChanges:=False
ActiveWorkbook.Close SaveChanges:=False
End Sub
Copy all previously filtered data from all worksheets to another
Sub CopyFilteredDataToNewWorkbook()
Dim newBook As Excel.Workbook
Dim rng As Excel.Range
Dim sht As Excel.Worksheet
Dim rowoffsetcount As Long
Dim newsht As Excel.Worksheet
Set newBook = Workbooks.Add
' ThisWorkbook.Worksheets is the same as the Sheets or Worksheets object, but more explicit
For Each sht In ThisWorkbook.Worksheets
' Get the used rows and columns
Set rng = sht.UsedRange
' Offset the range so it starts at row 15
rowoffsetcount = 15 - rng.Row
Set rng = rng.Offset(rowoffsetcount)
' Check there will be something to copy
If (rng.Rows.Count - rowoffsetcount > 0) Then
' Reduce the number of rows in the range so it ends at the same row
Set rng = rng.Resize(rng.Rows.Count - rowoffsetcount)
' Check that there is a sheet we can copy it to
On Error Resume Next
Set newsht = Nothing
Set newsht = newBook.Worksheets(sht.Index)
On Error GoTo 0
' We have run out of sheets, add another at the end
If (newsht Is Nothing) Then
Set newsht = newBook.Sheets.Add(, newBook.Worksheets(newBook.Worksheets.Count))
End If
' Give it the same name
newsht.Name = sht.Name
' Get the range of visible (i.e. unfiltered) rows
' (can't do this before the range resize as that doesn't work on disjoint ranges)
Set rng = rng.SpecialCells(xlCellTypeVisible)
' Paste the visible data into the new sheet
rng.Copy newsht.Range("A1")
End If
Next
End Sub
I think this line is your problem:
'/* you only worked on Range("A2") */
Sheet1.Range("A2").SpecialCells(xlCellTypeVisible).Copy
You should access your tbl object like:
'/* this will give you the entire filtered table body */
tbl.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
Similarly, you can use:
Sheet1.Range("YourTableName").SpecialCells(xlCellTypeVisible).Copy
And lastly, avoid all objects with Active prefix (e.g. ActiveWorkbook, ActiveWindow). You already know how to assign variables, then be consistent about it.
I am attempting to consolidate some data into a specific excel template I have created. My data is titled as PAxxx.xx where x could be any number between 0-9. Is there a way I can search through my current workbook for that specific title "PAxxx.xx" and populate it into my created template field.
I current have this search function in VBA:
Sub CopyPasteCellData()
Dim FirstAddress As String
Dim searchTerms As Variant
Dim Rcount As Long
Dim I As Long
Dim Rng As Range
Dim currentWorkbook As Workbook
Dim newWorkbook As Workbook
Dim currentWorksheet As Worksheet
Dim newWorksheet As Worksheet
Set currentWorkbook = Workbooks("LVX Release 2015 (2).xlsm")
Set currentWorksheet = currentWorkbook.Sheets("PA5179.01")
Set newWorkbook = Workbooks("Test.xlsx")
Set newWorksheet = newWorkbook.Sheets("Sheet1")
'newWorksheet.Range("C2").Value = currentWorksheet.Range("A1").Value
searchTerms = Array("PA")
With currentWorksheet.UsedRange
Rcount = 0
For I = LBound(searchTerms) To UBound(searchTerms)
Set Rng = .Find(What:=searchTerms(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
newWorksheet.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
End Sub
Just not sure how to search the sheet for all data sets PAxxx.xx.
Thanks in advance :)
Here is a basic principle how to loop through all the sheets and find for a PAxxx.xx -> read instructions of Like operator if you need to change the validation ->
Sub LoopTroughWorkSheetsAndFindPA()
Dim wb As Workbook: Set wb = ThisWorkbook 'anyreference of a workbook you want
Dim ws As Worksheet
For Each ws In wb.Worksheets
If ws.Name Like "PA###.##" Then
'do some operations here for example ->
Debug.Print ws.Name
End If
Next
End Sub
I have maintained two Excel reports EPC1.xlsx and Control Power Transformers.xlsm respectively.
I want to trigger an button click from Control Power Transformers.xlsm report where it will search for "CTPT" term in "A" column from EPC1.xlsx, once it finds the term it need to copy Column B and Column c till the row ends (in EPC1.xlsx) and paste it in Control Power Transformers.xlsm workbook
I am successful in retrieving the cell address of "CTPT" term but how to select the data from adjacent column B and C?
And this is what I have tried
Private Sub CommandButton23_Click()
Dim rngX As Range
Dim num As String
Windows("EPC 1.xlsx").Activate
Set rngX = Worksheets("Sheet1").Range("A1:A10000").Find("CTPT", Lookat:=xlPart)
num = rngX.Address ' Here we will the get the cell address of CTPT ($A$14)
Range(rngX, Range("C" & rngX.Row).End(xlDown)).Copy
Windows("Control Power Transformers.xlsm").Activate
Sheets("Sheet2").Select
ActiveSheet.Range("E2").PasteSpecial (xlPasteValues)
End Sub
Paste the below in sample workbook. The below code will help to select both files using file dialog. It will search for word "CTPT". if so it will copy the column values from CTPT sheet to control file.
Sub DetailsFilePath()
Dim File1 As String
Dim File2 As String
Dim findtext As String
Dim copyvalues As Long
Dim c As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
MsgBox "Open the CTPT file"
Application.FileDialog(msoFileDialogFilePicker).Show
'On Error Resume Next
' open the file
File1 = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
MsgBox "Open the Control Power Transformers file"
Application.FileDialog(msoFileDialogFilePicker).Show
File2 = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
Set wb1 = Workbooks.Open(Filename:=File1)
Set ws1 = wb1.Worksheets("sheet1")
Set wb2 = Workbooks.Open(Filename:=File2)
Set ws2 = wb2.Worksheets("sheet1")
findtext = "CTPT"
With ws1.Columns(1)
Set c = .Find(findtext, LookIn:=xlValues)
If Not c Is Nothing Then
copyvalues = c.Column
ws2.Columns(2).Value = ws1.Columns(2).Value
ws2.Columns(3).Value = ws1.Columns(3).Value
End If
End With
wb1.Close savechanges:=True
wb2.Close savechanges:=True
End Sub
You need to use FindNext to find other results, and the Offset will help you select what you want from the address of your results :
Sub test_Karthik()
Dim WbEPC As Workbook, _
WbCPT As Workbook, _
WsEPC As Worksheet, _
WsCPT As Worksheet, _
FirstAddress As String, _
WriteRow As Long, _
cF As Range, _
num As String
Set WbEPC = Workbooks("EPC 1.xlsx")
Set WbCPT = Workbooks("Control Power Transformers.xlsm")
Set WsEPC = WbEPC.Sheets("Sheet1")
Set WsCPT = WbCPT.Sheets("Sheet2")
With WsEPC
.Activate
With .Range("A1:A10000")
'First, define properly the Find method
Set cF = .Find(What:="CTPT", _
After:=ActiveCell, _
LookIn:=xlValues, _
Lookat:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
'If there is a result, keep looking with FindNext method
If Not cF Is Nothing Then
FirstAddress = cF.Address
Do
num = cF.Address ' Here we will the get the cell address of CTPT ($A$14)
WsEPC.Range(cF.Offset(0, 1), cF.Offset(0, 2).End(xlDown)).Copy
WriteRow = WsCPT.Range("E" & WsCPT.Rows.count).End(xlUp).Row + 1
WsCPT.Range("E" & WriteRow).PasteSpecial (xlPasteValues)
Set cF = .FindNext(cF)
'Look until you find again the first result
Loop While Not cF Is Nothing And cF.Address <> FirstAddress
End If
End With
End With
End Sub
I have a working VBA macro which copies from one spreadsheet 'AverageEarnings' to another 'Sheet1', under the condition that Column AO has the word 'UNGRADED' in it. The macro copies the entirety of these conditional rows to Sheet1. I am looking to copy columns B and C ('AverageEarnings') to columns A and B ('Sheet1'). How do I amend this.
Sub UngradedToSHEET1()
' UngradedToSHEET1 Macro
'
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim stringToFind As String
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("AverageEarnings")
stringToFind = "UNGRADED"
With ws1
'Remove all filters from spreadsheet to prevent loss of information.
.AutoFilterMode = False
lRow = .Range("AO" & .Rows.Count).End(xlUp).Row 'Find a specific column.
With .Range("AO1:AO" & lRow) ' This is the row where GRADED or UNGRADED is specified.
.AutoFilter Field:=1, Criteria1:="=*" & stringToFind & "*" 'Filter specific information.
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'Remove spreadsheet filters again.
.AutoFilterMode = False
End With
Set ws2 = wb1.Worksheets("Sheet1")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then ' Find a blank row after A1.
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy .Rows(lRow)
End With
End Sub
This line copies the entire row:
Set copyFrom =
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
You will need to change EntireRow to just copy the columns you want, probably something like:
Set copyFrom =
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Range(.Cells(1,2),.Cells(1,3))
Hope this helps, I can't check this right now.