I need help in figuring out a macro to copy and paste only values from rows that contain data (and not a large set range) to another worksheet.
The worksheet named DataEntry is where downtime is entered in columns A - J (could have 2 rows of data or could have 50) and pastes only the values (and not formulas) into another worksheet named DataCombined to column A and on the next available row.
Please help!
Your question is kind of confusing, but this may be where you want to start:
(If you could please give an example sheet with your desired output, that would help)
Sub copyRange()
Dim dataSht As Worksheet, comboSht As Worksheet
Set dataSht = Sheets("DataEntry")
Set comboSht = Sheets("DataCombined")
Dim rngToCopy As Range
Set rngToCopy = dataSht.Range(Cells(2, 1), Cells(getLastFilledRow(dataSht), "J"))
rngToCopy.Copy
comboSht.Range("A" & (getLastFilledRow(comboSht) + 1)).PasteSpecial xlPasteValues
rngToCopy = dataSht.Range(Cells(2, 1), Cells(getLastFilledRow(dataSht), "J")).SpecialCells(xlCellTypeConstants)
rngToCopy.ClearContents
End Sub
'Gets the last row of the worksheet that contains data
Public Function getLastFilledRow(sh As Worksheet) As Integer
On Error Resume Next
getLastFilledRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Related
I need to calculate the last row in every worksheet of my excel workbook and I'm actually doing that with the following lines of code:
With Sheets("Sheetname")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow = 1
End If
End With
Is it possible to loop over every worksheet and store the LastRow values with a different name every time? I need all of them to be stored separately in my Macro.
You can loop through Worksheets like this:
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
'do something
Next ws
You could use a Scripting.Dictionary to store your values with ws.Name as Key and your .Cells.Find as Value. Place the code where the 'do something comment is.
I use a third party to collect data in order to produce a monthly report. In this example, the data dump from the third party is in the sheet called "Data" and the report sheet is called "Month"
Sheets("Data") This is the data dump of unstructured data listed by segment, although the order of the segments do not match my report:
Sheets("Month") This is the structured reporting sheet that lists data by segment appropriate for the report. Copied data from the 'Data' sheet will be pasted into columns O through S
I am looking to write a loop that can search through "Data", find each successive word in column B "Month" and paste the appropriate information from "Data" into "Month".
Right now, I have a long code that works, but it is easily broken if one of the segment names change. This is a small piece that just focuses on Segment 4.
Sub Macro1()
' Macro1 Macro
' For post onto StackOverflow
Dim ws As Worksheet
Dim qb As Worksheet
Dim aCell As Range
Set ws = ThisWorkbook.Sheets("Month")
Set qb = ThisWorkbook.Sheets("Data")
'To find Segment 4
With ws
Set aCell = .Columns(2).Find(What:="Segment 4", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not aCell Is Nothing Then
aCell.Offset(0, 1).Value = qb.Range("B2")
Else
MsgBox "Segment 4 Not Found"
End If
qb.Range("B2:F2").Copy
aCell.Offset(0, 13).Select
ActiveCell.PasteSpecial
End With
End Sub
Is there a way I can loop through Column B in "Month" and match it to data in Column A in "Data" without having to write a search for each Segment?
Thanks in advance for your input!
How about a For Each loop going through column A of Data:
Sub Macro1()
' Macro1 Macro
' For post onto StackOverflow
Dim ws As Worksheet
Dim qb As Worksheet
Dim aCell As Range
Set ws = ThisWorkbook.Sheets("Month")
Set qb = ThisWorkbook.Sheets("Data")
qb.Activate
Dim dataCell As Variant
For Each dataCell In qb.Range(Cells(2, 1), Cells(qb.Cells(qb.Rows.Count, "A").End(xlUp).Row, 1))
With ws
Set aCell = .Columns(2).Find(What:=dataCell.Value, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not aCell Is Nothing Then
Range(aCell.Offset(0, 1), aCell.Offset(0, 5)).Value = Range(dataCell.Offset(0, 1), dataCell.Offset(0, 5)).Value
Else
MsgBox dataCell.Value & " Not Found"
End If
End With
Next dataCell
End Sub
I am trying to consolidate multiple worksheets in Excel into 1 worksheet. I use the consolidated worksheet to run a suite of reports in the same workbook.
The number of worksheets that need to be consolidated varies - approx 6 to 40 worksheets. I identify the sheets to be consolidated by prefixing them with "Src"
There are approx 40 other spreadsheets in the same workbook (reports that run off the consolidated worksheet and other calculations)
The format of each worksheet to be consolidated is the same
I am new to macros so have found some code on the internet to automate the consolidation but by the time I have 12 worksheets or so that need to be consolidated it runs very slowly.
Is there anyway that I am able to speed up this macro?
Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Clear the consol worksheet except the top row with the headings
Set DestSh = ActiveWorkbook.Worksheets("All Data")
DestSh.Rows("5:" & Rows.Count).ClearContents
' Fill in the start row.ie the row in each of the source sheets that contain the data (do not include heading rows)
StartRow = 5
' Loop through all worksheets and copy the data to the
' summary worksheet if worksheet name starts with src.
For Each sh In ActiveWorkbook.Worksheets
If LCase(Left(sh.Name, 3)) = "src" Then
' Find the last row with data on the summary
' and source worksheets.
Last = LastRow(DestSh)
shLast = LastRow(sh)
' If source worksheet is not empty and if the last
' row >= StartRow, copy the range.
If shLast > 0 And shLast >= StartRow Then
'Set the range that you want to copy
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
' Test to see whether there are enough rows in the summary
' worksheet to copy all the data.
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
' This statement copies values, and formats.
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.GoTo DestSh.Cells(1)
' AutoFit the column width in the summary 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
Under the assumption that you have one column where there is no blank row from start to end, try replacing the LastRow() function with
Function LastRow(sh As Worksheet)
Dim i as Long, R as Range
i = 1
Set R = sh.[A1]
Do while R(i,1) <> "" ' we asume column A (.. 1) here
i = i+1
Loop
LastRow = i
End Function
Alternatively you can play with the .CurrentRegion property to avoid counting rows & columns alltogether.
Replace:
Last = LastRow(DestSh)
shLast = LastRow(sh)
with
Last = DestSh.UsedRange.Rows.Count
shLast = sh.UsedRange.Rows.Count
You have a LastCol(sh) function, but I'm not actually seeing a call to it. If I'm missing it, you can replace the function call with:
sh.UsedRange.Columns.Count
Normally, a paste will copy both the values and the formatting, so unless there's something in particular you're trying to avoid, replace:
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
with
DestSh.Cells(Last + 1, "A").Paste
Application.CutCopyMode = False
Finally, remember that VBA code is interpreted as it executes and will inherently be slower than pre-compiled code. Also, it's still significantly quicker than doing it by hand!
I am completely new for VBA.
I have excel data sheet containing numbers and strings. I want to search for certain string say 'CYP' in column I then look for a cell of its row at column C and copy entire rows containing the string of cell C. I want to paste in sheet 2 of the same workbook and loop it again to look for remaining CYPs in column.
Would you help me on this please?
After the suggestion from pnuts, here is my macro code
Sub Macro1()
'
' Macro1 Macro
'
'
Columns("I:I").Select
Range("I729").Activate
Selection.Find(What:="cyp", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveWindow.SmallScroll Down:=5
Range("C749").Select
Selection.Copy
Columns("C:C").Select
Range("C734").Activate
Selection.Find(What:="EPT001TT0601C000151", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
, MatchCase:=False, SearchFormat:=False).Activate
Rows("746:750").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
End Sub
In this code the CYP was found in I749, cell C749 was copied as string and first row in column C containing the same string was searched followed by copying of the entire row and 4 more followed by it then pasting in sheet2 of the same workbook.
What I wanted was to loop this action again and again upto the end of column I and repeat the same action.
Thank you!
I managed to solve the problem with the help of Trebor76 at Excelforum. Here I am giving solution in that way it might be helpful for some newbies like myself with similar problem.
Option Explicit
Sub Macro1()
'Written and assisted by Trebor76
'Copy an entire row from Sheet1 to Sheet2 for each unique matching item in Col. C if the text in Col. I contains the text 'CYP' (case sensitive)
'http://www.excelforum.com/excel-programming-vba-macros/962511-vba-for-searching-string-in-a-column-and-copy-rows-depending-on-string-in-adjacent-cell.html
Dim rngCell As Range
Dim objMyUniqueArray As Object
Dim lngMyArrayCounter As Long
Dim lngMyRow As Long
Dim varMyItem As Variant
Application.ScreenUpdating = False
Set objMyUniqueArray = CreateObject("Scripting.Dictionary")
For Each rngCell In Sheets("Sheet1").Range("I1:I" & Sheets("Sheet1").Range("I" & Rows.Count).End(xlUp).Row)
If InStr(rngCell, "CYP") > 0 Then
If Not objMyUniqueArray.Exists(Trim(Cells(rngCell.Row, "C"))) Then
lngMyArrayCounter = lngMyArrayCounter + 1
objMyUniqueArray.Add (Trim(Cells(rngCell.Row, "C"))), lngMyArrayCounter
varMyItem = Sheets("Sheet1").Cells(rngCell.Row, "C")
For lngMyRow = 1 To Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
If Sheets("Sheet1").Cells(lngMyRow, "C") = varMyItem Then
Rows(lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Next lngMyRow
End If
End If
Next rngCell
Set objMyUniqueArray = Nothing
Application.ScreenUpdating = True
MsgBox "All applicable rows have been copied.", vbInformation
End Sub
Cheers!
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