Hi currently i have a code that helps me to copy and paste information on a new found row from external workbook based on a matching condition such as "Singapore". The code will look through the sheet in the external workbook and search for all rows that have "Singapore" in the column and paste it to another workbook. But the problem i am facing right now is that the rows that is being copied and paste to is overlapping my column header instead of inserting on the last row of the sheet.
Below is the image that the information from the external workbook will be pasted to.
However when i run the code as below:
Sub UpdateNewUpcomingProj()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel
Dim strSearch As String
Set wb1 = Application.Workbooks.Open("U:\Active Master Project.xlsm")
Set ws1 = wb1.Worksheets("New Upcoming Projects")
strSearch = "Singapore"
With ws1
'~~> Remove any filters
.AutoFilterMode = False
'~~> I am assuming that the names are in Col A
'~~> if not then change A below to whatever column letter
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
End With
'~~> Destination File
Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("New Upcoming Projects")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A2"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 2
End If
copyFrom.Copy
.Rows(lRow).PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone, False, False
.Rows.RemoveDuplicates Array(2), xlNo
End With
End Sub
It give this result:
It seems that the information is overlapping the column header instead of pasting it below the column header itself. I hope anyone could assist me in the codes to solve the problem of the rows being pasted on the column headers instead of on the empty rows. Any help would be appreciated. Thank you.
You might have to add the line
lRow = lRow + 1
after the section
lRow = .Cells.Find(What:="*", _
After:=.Range("A2"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Related
I am trying to copy all worksheets, one at a time, and pasting into a new worksheet. These files come from multiple third parties so the worksheets can vary. I'm running into a problem below when trying to determine last row Lrow and last column Lcol because an error appears saying Object doesn't support this property or method. I do plan on submitting this to my work so any help with error proofing or general macro tips are appreciated.
Sub ws_copy()
Dim Lrow As Long
Dim Lcol As Long
Dim Pasterow As Long
Dim WSCount As Integer
Dim i As Integer
'On Error Resume Next
'Application.DisplayAlerts = False
i = Application.InputBox(prompt:="Enter the place order of first tab to be copied.", Title:="Worksheet Consolidation", Type:=1)
If IsEmpty(i) = True Then
Exit Sub
Else
If IsNumeric(i) = False Then
MsgBox "Enter a numeric value."
Else
If IsNumeric(i) = True Then
Worksheets.Add(before:=Sheets(1)).Name = "Upload"
WSCount = Worksheets.Count
For i = i + 1 To WSCount
Lrow = Worksheets(i).Find("*", After:=Cells(1, 1), _
LookIn:=xlFormulas, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Lcol = Worksheets(i).Find("*", After:=Cells(1, 1), _
LookIn:=xlFormulas, _
Lookat:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Pasterow = Lrow + 1
Workbook.Worksheets(i).Range(Cells(1, 1), Cells(Lrow, Lcol)).Copy
Workbook.Worksheets("Upload").Cells(Pasterow, 1).Paste
Next i
Else
Exit Sub
End If
End If
End If
'On Error GoTo 0
'Application.DisplayAlerts = False
End Sub
A common way to find the last row/column is:
With Worksheets(i)
Lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
hth
Based on the comment that:
I can't assume any one column or row has the last piece of data because of the variety of the files received.
You should look at using the UsedRange property of the Worksheet (MSDN). UsedRange expands as more data is entered onto the worksheet.
Some people will avoid using UsedRange because if some data has been entered, and then deleted then UsedRange will include these 'empty' cells. The UsedRange will update itself when the workbook is saved. However, in your case, it doesn't sound like this is a relevant issue.
An example would be:
Sub Test()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim rngSource As Range
Dim rngTarget As Range
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
Set rngSource = wsSource.UsedRange
rngSource.Copy Destination:=wsTarget.Cells
End Sub
Here is a method of finding the last used row and last used column in a worksheet. It avoids the issues with UsedRange and also your issues of not knowing which row might have the last column (and which column might have the last row). Adapt to your purposes:
Option Explicit
Sub LastRowCol()
Dim LastRow As Long, LastCol As Long
With Worksheets("sheet1") 'or any sheet
If Application.WorksheetFunction.CountA(.Cells) > 0 Then
LastRow = .Cells.Find(what:="*", after:=[A1], _
LookIn:=xlFormulas, _
searchorder:=xlByRows, _
searchdirection:=xlPrevious).Row
LastCol = .Cells.Find(what:="*", after:=[A1], _
LookIn:=xlFormulas, _
searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Else
LastRow = 1
LastCol = 1
End If
End With
Debug.Print LastRow, LastCol
End Sub
Although the basic technique has been long used, Siddarth Rout, some time ago, posted a version adding COUNTA to account for the case where the worksheet might be empty -- a useful addition.
If you want to merge data on each sheet into one MasterSheet, run the script below.
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:G1")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Also, see the link below for some other options to do this slightly differently.
http://www.rondebruin.nl/win/s3/win002.htm
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.
I would like to ask if you can help with the code below. On every sheet in my workbook there is the same kind of a table, however on each sheet the table has different location and values. I need to go through all sheets, search for table values on every sheet and then do some other operations with the values. I use Find function to determine header of the table and subsequently table range. The Find function does not work properly though as it keeps found address of "Header" cell from the first sheet for every other sheet. Is there any way to reset the found header address value before looping to another sheet? Thank you in advance.
Sub FindInDynamicRanges()
Dim wb1 As Workbook
Dim ws As Worksheet
Dim FoundCell, FoundTab, TabEntries As Excel.Range
Dim FirstAddr As String
Dim FirstRow, LastRow As Long
Set wb1 = ThisWorkbook
'Find all occurences of any table value on all sheets in dynamic ranges
For Each ws In wb1.Worksheets
Set ws = ActiveSheet
'Find "Header" cell
Set FoundCell = ws.Columns(2).Find(What:="Header", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
MsgBox FoundCell.Address
'Set number of first entry row and last entry row
FirstRow = FoundCell.Row + 1
LastRow = ws.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlValues, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
ws.Range("B" & FirstRow & ":B" & LastRow).Name = "TabEntries"
MsgBox Range("TabEntries").Address
With ws.Range("TabEntries")
Set LastCell = .Cells(.Cells.Count)
End With
Set FoundTab = ws.Range("TabEntries").Find(What:="*", After:=LastCell, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not FoundTab Is Nothing Then
FirstAddr = FoundTab.Address
End If
Do Until FoundTab Is Nothing
'do some staff with found values
Set FoundTab = ws.Range("TabEntries").FindNext(After:=FoundTab)
If FoundTab.Address = FirstAddr Then
Exit Do
End If
Loop
Next ws
End Sub
as it keeps found address of "Header" cell from the first sheet for every other sheet.
That is because you are telling it to...
For Each ws In wb1.Worksheets
Set ws = ActiveSheet
You don't need that Set ws = ActiveSheet
When you say For Each ws, the ws is automatically initialized. So just remove the second line.
Sheets("DATA").Rows(2).Find(What:="Apple", LookIn:=xlValues, _
LookAt:=xlWhole).Offset(1, 0).Value = "=A3-B3"
Selection.FillDown
I want to find a column "Apple" in Row 2 and filldown with formula "A3-B3"
Would something like .value="=A3-B3".filldown work?
Thanks!
Further to my comments above, try this. I have commented the code. Do let me know if you find anything confusing...
Sub Sample()
Dim ws As Worksheet
Dim LRow As Long
Dim aCell As Range
'~~> Set this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Data")
With ws
'~~> Find Last Row
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Find the cell which has "Apple"
Set aCell = .Rows(2).Find(What:="Apple", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> if found, then enter the formula till the last row IN ONE GO
If Not aCell Is Nothing Then
.Range(.Cells(3, aCell.Column), .Cells(LRow, aCell.Column)).Formula = "=A3-B3"
End If
End With
End Sub
I have a spread sheet and I need to look for the last column that has data in it. Then I need to copy this column and copy it to the next blank column.
Is there a way to do this?
I've managed to do it with rows using:
lastrowSrc = Sheets("Overview").Range("B" & Rows.Count).End(xlUp).Row
However this puts B12 in the range, using columns.count simply puts in the number of the column, not the letter
To get the exact column in a worksheet, use this code.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LastCol As Long
Set ws = Sheets("Sheet1")
'~~> This check is required else .FIND will give you error on an empty sheet
If Application.WorksheetFunction.CountA(ws.Cells) = 0 Then
LastCol = 1
Else
LastCol = ws.Cells.Find(What:="*", _
After:=ws.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End If
Debug.Print LastCol
End Sub
EDIT: This is courtesy #brettdj. You can also use the range object to find the last column
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LastCol As Long
Dim rng As Range
Set ws = Sheets("Sheet1")
Set rng = ws.Cells.Find(What:="*", _
After:=ws.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If rng Is Nothing Then
LastCol = 1
Else
LastCol = rng.Column
End If
Debug.Print LastCol
End Sub
To get the last column of a particular row, say row 1 use this
Debug.Print ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Where ws is your relevant worksheet.
Similarly for Row see this.
I found that some of the answers didn't work for my worksheet that had a few rows at the end that were shorter than the others in the worksheet. The code provided just gives the last column of the last row of the worksheet. Instead, I used a loop around code to find the last column in a row, using the Find example to get the last row in the workbook.
Sub Sample()
Dim ws As Worksheet
Dim CurrRow, RowLastCol, LastRow, LastCol As Long
Set ws = Sheets("Sheet1")
'~~> This check is required else .FIND will give you error on an empty sheet
If Application.WorksheetFunction.CountA(ws.Cells) = 0 Then
LastCol = 1
Else
LastCol = 0
LastRow = ws.Cells.Find(What:="*", _
After:=ws.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
' Loop through all the rows of the sheet saving off the highest column count
For CurrRow = 1 to LastRow
RowLastCol = ws.Cells(CurrRow, Columns.Count).End(xlToLeft).Column
If RowLastCol > LastCol Then
LastCol = RowLastCol
End If
Next CurrRow
End If
Debug.Print LastCol
End Sub