I need to copy the last line of data, copy it with formulas to the row below it and then do a find and replace on the new last row - I got it to copy the line down but the find and replace isnt working - any tips? Thanks.
Sub CopyLastRowandReplace()
Dim sourceSheet As Worksheet
Dim sourceRange As Range
Dim LastRow As Long
Dim ReplaceRow As Range
Set sourceSheet = ThisWorkbook.Worksheets("Book 1")
LastRow = sourceSheet.Range("B" & sourceSheet.Rows.Count).End(xlUp).Row
Set sourceRange = sourceSheet.Range("B" & LastRow & ":N" & LastRow)
sourceRange.Offset(1).Formula = sourceRange.Formula
Set ReplaceRow = sourceSheet.Range("B" & LastRow & ":N" & LastRow)
Range("B" & LastRow & ":N" & LastRow).Select
Selection.Replace What:="Aug", Replacement:="Sep", LookAt:=xlFormulas, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
Core problems
LookAt:=xlFormulas. Sould be xlPart or xlWhole
You are not Replacing in the New last row (you haven't updated LastRow)
That said, there are other oportunities for improvement too
Sub Demo()
CopyLastRowandReplace ThisWorkbook.Worksheets("Book 1"), 2, 13, "Aug", "Sep"
End Sub
Sub CopyLastRowandReplace(sourceSheet As Worksheet, StartColumn As Long, NumColumns As Long, FindValue As Variant, ReplaceValue As Variant)
Dim sourceRange As Range
Set sourceRange = sourceSheet.Cells(sourceSheet.Rows.Count, StartColumn).End(xlUp).Resize(1, NumColumns)
With sourceRange
.Offset(1, 0).Formula = .Formula
.Offset(1, 0).Replace _
What:=FindValue, _
Replacement:=ReplaceValue, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=True, _
SearchFormat:=False, _
ReplaceFormat:=False
End With
End Sub
Related
I want to loop or find multiple value in another sheets. My code doesn't work even after I do..loop the code.
For i = 1 To lastrowBAU
Worksheets(fname).Range("A1:A" & lastrowsheet).Select
Do Until Cell Is Nothing
Set Cell = Selection.find(What:=ThisWorkbook.Worksheets("BAU").Range("A" & i).Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False)
If Not Cell Is Nothing Then
Cell.Activate
ActiveCell.Copy
ActiveCell.Insert Shift:=xlShiftDown
ActiveCell.Offset(1, 0).Select
Selection.Replace What:=ThisWorkbook.Worksheets("BAU").Range("A" & i).Value, _
replacement:=ThisWorkbook.Worksheets("BAU").Range("B" & i).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Set Cell = Worksheets(fname).Range("A1:A" & lastrowsheet).FindNext(Cell)
End If
Loop
Next i
You need to set the cell before entering the loop
Set cell = rngSrc.Find(sA, LookIn:=xlFormulas, LookAt:=xlPart, _
After:=rngSrc.Cells(rngSrc.Cells.Count), SearchOrder:=xlByRows, MatchCase:=False)
If Not cell Is Nothing Then
however you also need to avoid an endless loop by checking if the search has returned to the first one found.
Option Explicit
Sub macro1()
Dim ws As Worksheet, wsBAU As Worksheet
Dim cell As Range, rngSrc As Range
Dim fname As String, lastrow As Long, lastrowBAU As Long
Dim i As Long, n As Long, first As String
Dim sA As String, sB As String
fname = "Sheet1"
With ThisWorkbook
Set ws = .Sheets(fname)
Set wsBAU = .Sheets("BAU")
End With
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngSrc = .Range("A1:A" & lastrow)
End With
With wsBAU
lastrowBAU = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngSrc = .Range("A1:A" & lastrow)
End With
' search and replace
Application.ScreenUpdating = False
For i = 1 To lastrowBAU
sA = wsBAU.Cells(i, "A")
sB = wsBAU.Cells(i, "B")
Set cell = rngSrc.Find(sA, LookIn:=xlFormulas, LookAt:=xlPart, _
After:=rngSrc.Cells(rngSrc.Cells.Count), SearchOrder:=xlByRows, MatchCase:=False)
If Not cell Is Nothing Then
first = cell.Address
Do
' insert cell above
cell.Insert xlDown
cell.Offset(-1).Value2 = cell.Value2
cell.Value2 = Replace(cell.Value2, sA, sB)
' expand search range
n = n + 1
Set rngSrc = ws.Range("A1:A" & lastrow + n)
' find next
Set cell = rngSrc.FindNext(cell)
Loop While cell.Address <> first
End If
Next
Application.ScreenUpdating = True
MsgBox n & " replacements", vbInformation
End Sub
This is about VBA in excel.
I am trying to remove the sign "/" and cut the string length for every cell down to 31 to make those values valid as a name for a new sheet. The constraint is within the first two columns until the last occupied row.
My code compiled, however, it brought me endless processing and I have to task manager-exit every time after running it. Please take a look at it, thank you so much!
Sub replaceSpeCharaAndCutLength()
'selectPositionAndReplaceSpeCharaAndCutLength Macro
Dim cell As Range
Dim row As Long
For row = 7 To Sheet1.Cells(Rows.Count, 1).End(xlUp).row
Worksheets("Sheet1").Columns("A").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
Worksheets("Sheet1").Columns("B").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
For Each cell In Sheet1.Range("A:B").Cells
cell.Value = Left(cell.Value, 31)
Next cell
Next row
End Sub
Updated code 0142 08212020
Sub replaceSpeCharaAndCutLength()
'
' selectPositionAndReplaceSpeCharaAndCutLength Macro
'
Dim cell As Range
Worksheets("Sheet1").Columns("A").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
Worksheets("Sheet1").Columns("B").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
For Each cell In Sheet1.Range("A:B").Cells
cell.Value = Left(cell.Value, 31)
Next cell
End Sub
Range.Replace doesn't require a loop. You can also use Evaluate instead of the other loop:
Sub replaceSpeCharaAndCutLength()
Dim lastRow As Long
lastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
Dim rng As Range
Set rng = Sheet1.Range("A7:B" & lastRow)
rng.Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
rng.Value = rng.Parent.Evaluate("INDEX(LEFT(" & rng.Address & ",31),)")
End Sub
I am trying to accelerate my Excel VB Macro.
I have tried the 5 alternatives below.
But I wonder if I could shorten the execution further.
I found 2 alternatives in User Blogs which I could not get to work.
One alternative is also found in a User Blog but do not understand.
Sub AccelerateMacro()
'
' v1 052817 by eb+mb
' Macro to copy as fast as possible sheet from one workbook into another workbooks
' Declarations for variables are not shown to make code example more legible
' Macro is stored in and run from "DestinationWorkBook.xlsm"
StartTime = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Alternative = "First"
If Alternative = "First" Then
Workbooks.Open Filename:="SourceWorkBook.xls"
Cells.Select
Selection.Copy
Windows("DestinationWorkBook.xlsm").Activate
Sheets("DestinationSheet").Select
Range("A1").Select
ActiveSheet.Paste
Windows("SourceWorkBook.xls").Activate
ActiveWorkbook.Close
End If
If Alternative = "Second" Then
Workbooks.Open Filename:="SourceWorkBook.xls", ReadOnly:=True
Cells.Select
Selection.Copy
Windows("DestinationWorkBook.xlsm").Activate
Sheets("DestinationSheet").Select
Range("A1").Select
ActiveSheet.Paste
Workbooks("SourceWorkBook.xls").Close SaveChanges:=False
End If
If Alternative = "Third" Then
' I could not get this alternative to work
Workbooks.Open("SourceWorkBook.xls").Worksheets("SourceSheet").Copy
Workbooks.Open("DestinationWorkBook.xlsm").Worksheets("DestinationSheet").Range("A1").PasteSpecial
End If
If Alternative = "Fourth" Then
' I could not get this alternative to work
Workbooks.Open("DestinationWorkBook.xlsm").Worksheets("DestinationSheet").Range("A1") = Workbooks.Open("SourceWorkBook.xls").Worksheets("SourceSheet")
End If
If Alternative = "Fifth" Then
' I don't understand the code in this alternative
Dim wbIn As Workbook
Dim wbOut As Workbook
Dim rSource As Range
Dim rDest As Range
Set wbOut = Application.Workbooks.Open("DestinationWorkBook.xlsm")
Set wbIn = Application.Workbooks.Open("SourceWorkBook.xls")
With wbIn.Sheets("SourceSheet").UsedRange
wbOut.Sheets("DestinationSheet").Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Instead of using UsedRange, find the actual Last Row and Last Column and use that range. UsedRange may not be the range that you think it is :). You may want to see THIS for an explanation.
See this example (UNTESTED)
Sub Sample()
Dim wbIn As Workbook, wbOut As Workbook
Dim rSource As Range
Dim lRow As Long, LCol As Long
Dim LastCol As String
Set wbOut = Workbooks.Open("DestinationWorkBook.xlsm")
Set wbIn = Workbooks.Open("SourceWorkBook.xls")
With wbIn.Sheets("SourceSheet")
'~~> Find Last Row
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find Last Column
LCol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Column Number to Column Name
LastCol = Split(Cells(, LCol).Address, "$")(1)
'~~> This is the range you want
Set rSource = .Range("A1:" & LastCol & lRow)
'~~> Get the values across
wbOut.Sheets("DestinationSheet").Range("A1:" & LastCol & lRow).Value = _
rSource.Value
End With
End Sub
Sorry about the flury of posting, I am trying to finish a project (there always seems to be one more thing)
I am tring to auto sort to last column starting at F2 I have the following but is not working
Thanks
Sub Sort()
Dim lastRow As Long
Dim lastCol As Long
Dim ws As Worksheet
Set ws = Sheets("sheet1")
lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
lastCol = Cells(2, ws.Columns.Count).End(xlToLeft).Column
With Sheets("Sheet1")
ws.Range(ws.Range("F2"), ws.Cells(lastRow, lastCol)).Sort _
Key1:=Range("lastCol"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End Sub
The value for Key1 must be a range. You are trying to use the number that is the last column, and that won't work even if you remove the quotation marks.
Replace Key1:=Range("lastCol")
with Key1:=Cells(2, lastCol)
Note that you can use the GetColumnLetter function I included in my previous answer to get the letter for the lastCol column. If you have the letter, you can use this syntax instead of the Cells version:
Key1:=Range(myCol & 2)
To make sure you know what you are sorting, you can add a little bit of debugging code. You can also use the Immediate window and the Watch window to figure this out.
Replace your entire sub with this:
Sub Sort()
Dim lastRow As Long
Dim lastCol As Long
Dim ws As Worksheet
Dim rng As Range
Dim sortRng As Range
Set ws = Sheets("sheet1")
lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
lastCol = Cells(2, ws.Columns.Count).End(xlToLeft).Column
Set rng = ws.Range(ws.Range("F2"), ws.Cells(lastRow, lastCol))
Set sortRng = ws.Cells(lastRow, lastCol)
MsgBox "I will sort this range: " & rng.Address & _
" using this column: " & sortRng
rng.Sort Key1:=sortRng, Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
Following is the code to fetch the data from the last column of each sheet and display it in the sheet "MainSheet". Since the last column has merged cells this code also deletes the cells in between
This code displays the data as verical view in the MainSheet and I want to make it horizontal i.e data from the last column of each sheet should be fetched to the rows in the MainSheet and also the merged cells should be taken care of
Sub CopyLastColumns()
Dim cnt As Integer, sht As Worksheet, mainsht As Worksheet, col As Integer, rw As Integer
ActiveSheet.Name = "MainSheet"
Set mainsht = Worksheets("MainSheet")
cnt = 1
For Each sht In Worksheets
If sht.Name <> "MainSheet" Then
sht.Columns(sht.Range("A1").CurrentRegion.Columns.Count).Copy
mainsht.Columns(cnt).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
mainsht.Cells(150, cnt) = sht.Range("A2")
cnt = cnt + 1
End If
Next sht
With mainsht
For col = 1 To cnt
For rw = .Cells(65536, col).End(xlUp).row To 1 Step -1
If .Cells(rw, col) = "" Then
.Cells(rw, col).Delete Shift:=xlUp
End If
Next rw
Next col
End With
End Sub
Thanks in advance
This code copies the last column from every sheet and pastes them as rows in the MainSheet keeping the merged cells intact.
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim wsOLrow As Long, wsILrow As Long, wsILcol As Long
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wsO = Sheets("MainSheet")
wsOLrow = wsO.Cells.Find(What:="*", _
After:=wsO.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
For Each wsI In ThisWorkbook.Sheets
If wsI.Name <> wsO.Name Then
With wsI
wsILrow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
wsILcol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
.Range(Split(Cells(, wsILcol).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol).Address, "$")(1) & _
wsILrow).Copy .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
.Activate
With .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
.UnMerge
.Cells.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End With
wsILrow = .Range(Split(Cells(, wsILcol).Address, "$")(1) & Rows.Count).End(xlUp).Row
With .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
.Copy
wsO.Cells(wsOLrow, 1).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
.Delete
End With
wsOLrow = wsOLrow + 1
End With
End If
Next
LetsContinue:
Application.ScreenUpdating = True
MsgBox "Done"
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub