Paste cells to another worksheet in VBA - excel

I want to paste cells across worksheets in VBA. In the code below, I first select the range of cells, and then paste to another worksheet. But it runs error '9": Subscript out of range. I think the problem is in the last line for copy & paste. Here's my code:
Sub MatchFRB()
' find last row and column
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set StartCell = Range("A1")
LastRow = Sheet22.Cells(Sheet22.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = Sheet22.Cells(StartCell.Row, Sheet22.Columns.Count).End(xlToLeft).Column
' Select cells until meets Threshold=5000000000
Dim i As Integer
Dim Bal As Double
Threshold = 0
For i = 2 To LastRow
Bal = Threshold + Range("AV" & i)
If Threshold > 5000000000# Then
Exit For
End If
Next i
' copy cells from Sheet22 and paste to Sheet21
Sheet22.Range(StartCell, Sheet22.Cells(i, LastColumn)).Copy Worksheets("Sheet21").Range(StartCell, Sheet21.Cells(i, LastColumn))
End Sub
Many thanks!

You have to properly call to your sheet. VBA doesn't accept just the name of the sheet as an object. You have to reference to the sheet with Worksheets("Sheet22"), another option would be to set an object to be this:
Dim ws as object
set ws = Thisworkbook.Worksheets("Sheet22")
This way VBA knows you want Sheet22 from the book that the macro is in; otherwise you could specify the workbook with Workbooks("YourWorkBookName").WorkSheets("SheetName").
From there you could use ws.Range as you were doing with Sheet22. Similarly, StartCell may be a range, but it only acts with the active sheet, so it wouldn't be a bad idea to reference it to a certain sheet and/or book as well. But in this case, I've left it out because it's always A1 and that's simple enough to enter.
Later in your code when you're trying to calculate the balance, you also have to use .Value after you call your range so that you actually access the number stored in the cell. But if you're threshold is what you're checking you should be adding the threshold back to itself. However, I've chosen to just use Bal in this case because it made more sense to me.
Sub MatchFRB()
' find last row and column
Dim LastRow As Long
Dim LastColumn As Long
Dim ws as object
Dim i As Integer
Dim Bal As Double
set ws = Thisworkbook.Worksheets("Sheet22")
LastRow = ws.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastColumn = ws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
' Select cells until meets Threshold=5000000000
Bal = 0
For i = 2 To LastRow
Bal = Bal + ws.Range("AV" & i).Value
If Bal >= 5000000000 Then
Exit For
End If
Next i
' copy cells from Sheet22 and paste to Sheet21
ws.Range("A1:" & Cells(i, LastColumn).Address).Copy Worksheets("Sheet21").Range("A1:", Cells(i, LastColumn).address)
End Sub

Related

VBA - copying unique values into different sheet

Hoping you can help, please!
So I have 2 worksheets, 1 & 2. Sheet1 has already existing data, Sheet2 is used to dump raw data into. This is updated daily, and the data dump includes both data from previous days, as well as new data. The new data may include rows relating to interactions that may have happened earlier in the month, not just the previous day. So the data is not "date sequential".
There are 9 columns of data, with a unique identifier in column I.
What I'm needing to happen is when running the macro, it looks in column I in Sheet1 and Sheet2, and only copies and pastes rows where the unique identifier in Sheet 2 doesn't already exist in Sheet1. And pastes them from the last empty row onwards in Sheet1.
What I currently have is this - it's all I could find online:
Sub CopyData()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundVal As Range
For Each rng In Sheets("Sheet2").Range("A1:I" & LastRow)
Set foundVal = Sheets("Sheet1").Range("I:I").Find(rng, LookIn:=xlValues, LookAt:=xlWhole)
If foundVal Is Nothing Then
rng.EntireRow.Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next rng
Application.ScreenUpdating = True
End Sub
But it's just not working - not only does it not recognise if the value in column I already exists, it's copying and pasting only the first 2 rows from Sheet2, but duplicating them 8 times each!
Apologies in advance, I'm a real VBA novice, and just can't work out where it's all going wrong. I would appreciate any assistance!
This will do what you want:
Sub testy()
Dim wks As Worksheet, base As Worksheet
Dim n As Long, i As Long, m As Long
Dim rng As Range
Set wks = ThisWorkbook.Worksheets(2) 'Change "2" with your input sheet name
Set base = ThisWorkbook.Worksheets(1) 'Change "1" with your output sheet name
n = base.Cells(base.Rows.Count, "A").End(xlUp).Row
m = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
For i = 2 To m
On Error Resume Next
If IsError(WorksheetFunction.Match(wks.Cells(i, 9), base.Range("I:I"), 0)) Then
Set rng = wks.Cells(i, 1).Resize(1, 9) 'Change 9 with your input range column count
n = n + 1
base.Cells(n, 1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next i
End Sub

Runtime error 13 Type Mismatch VBA to highlight row if value is found in another workbook

I'm learning VBA in Excel 2013 and I posted a question last weekend but didn't receive a response. I've been working on the code more and narrowed the error down to one. I'm trying to highlight a row in a workbook if a value in column A is found in the column A another open workbook.
I get a Runtime error 13: Type mismatch error. That is all that it says and it is for this line of code:
If cell.Value = valuetofind Then
I have looked on numerous sites about this error but I don't see any that match my situation. I think it's b/c 'valuetofind' is a range and it's trying to set a range equal to a value, seen in 'cell.value'. I think all of my variables are declared properly.
I've tried changing it to below so that they are both ranges but that gives the same error:
If cell = valuetofind Then...
Can anyone help with this error?
Sub HighlightRow()
'http://www.vbaexpress.com/forum/showthread.php?26162-Solved-Highlight-ROW-based-on-cell-value
'http://www.mrexcel.com/forum/excel-questions/827262-visual-basic-applications-vlookup-between-2-workbooks.html
'test column just picks any column, I think, to test how far down the rows go to, I think you could choose any column
Const TEST_COLUMN As String = "D" '<=== change to suit
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastRow As Long
Dim cell As Range
Dim valuetofind As Range
Set ws1 = ThisWorkbook.Sheets(1) 'name will change each day
Set ws2 = ActiveWorkbook.Sheets(1) 'name will change each day
With ws1
LastRow = Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
'LastRow is testing/finding out last row using TEST_COLUMN first before performs rest of macro
End With
Set valuetofind = ws2.Range("A2:A" & LastRow)
'Range("A2:A" & LastRow) is the criteria row where it is looking for Break Down and PM/SM Call below
'Resize(,7) will highlight the row however many columns you tell it to, in this case 7
'cell.Offset(, -6) I think tells to go back 6 columns to column A and start the highlighting there
With ws1
For Each cell In Range("A2:A" & LastRow)
If cell.Value = valuetofind Then
'old, do not use: wb2.Worksheets(wb2SheetName).Range("A2:A" & LastRow)
cell.Offset(, -6).Resize(, 7).Interior.ColorIndex = 39
Else
cell.EntireRow.Interior.ColorIndex = xlNone
End If
Next
End With
End Sub
The code has been altered and is working for anyone who needs help.
This is modified from Dinesh Takyar's video on copying data between worksheets(https://www.youtube.com/watch?v=AzhQ5KiNybk_), though this code below is to highlight rows between workbooks. Both workbooks, destination and source workbooks, need to be open.
I believe the original Run Time 13 Error was b/c the criteria, original variable called 'valuetofind' was Dim as Range, when it is a String. The variable in the code below is now called 'myname' and is Dim as String. But I don't believe the code above would have worked anyway b/c I needed the For/Next to go through each cell in my criteria column.
Thanks to Dinesh and people on this forum.
Sub HighlightRowBtwWorkbook()
Dim wkbkDest As Workbook
Dim i As Long
Dim lastrowDest As Long
Dim lastcolDest As Long
Dim wkbkSource As Workbook
Dim j As Long
Dim lastrowSource As Long
Dim myname As String
Dim lastcolSource As Long
'Destination
Set wkbkDest = ThisWorkbook 'was Workbooks("Destination_VBAHighlight.xlsm") 'was ActiveWorkbook
lastrowDest = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
lastcolDest = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To lastrowDest
myname = wkbkDest.ActiveSheet.Cells(i, "A").Value
'Source
Set wkbkSource = Workbooks("TESTVBA.xlsm")
wkbkSource.Activate
lastrowSource = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
lastcolSource = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
For j = 2 To lastrowSource
If ActiveSheet.Cells(j, "A").Value = myname Then
'Activate Destination
wkbkDest.Sheets(1).Activate
ActiveSheet.Range(Cells(i, "B"), Cells(i, lastcolDest)).Interior.Color = RGB(252, 228, 214)
End If
Next j
Next i
'select cell A1 in Destination wkbk to end there
wkbkDest.Sheets(1).Activate
wkbkDest.ActiveSheet.Range("A1").Select
End Sub

Using CountA on one row ONLY and also using the cells found and putting them somewhere else

So I am learning VBA, I know how to program on Matlab and some C++. I am wondering how I can use the CountA to count all of the cells used on a specific row and only that row. ( I have multiple examples on ranges and columns but none on a Row only).I cannot use a range because I want to use this VBA in the future and this row will have a number of variables changing. I would also like to have the content(text) of those cells moved to another location with no spaces between them because right now they have three spaces between each used cell.
So far I have this code which isn't very much for the countA of the first row
Sub CountNonBlankCells()
Dim numcompanies As Integer
n = Sheet1.CountA(Rows(1))
Worksheets("start on this page").Range("B2") = n
End Sub
I have nothing for the part where I take that data from each cell to another location.
Sure you can use a Range. Your question is pretty broad, but for tutorial purpose ... here's a piece of code that counts the number of nonblank cells in a number of rows and shows you what's in each of them ...
Sub TestCount()
Dim mySht As Worksheet
Dim myRng As Range, oRow As Range
Dim lstRow As Long, lstCol As Long
Dim nUsed As Long
Dim iLoop As Long
Set mySht = Worksheets("Sheet13")
lstRow = mySht.Range("A1").End(xlDown).Row
lstCol = mySht.Range("A1").End(xlToRight).Column
Set myRng = mySht.Range(Cells(1, 1), Cells(lstRow, lstCol))
Debug.Print "Number of Rows is " & myRng.Rows.Count
For Each oRow In myRng.Rows
nUsed = Application.CountA(oRow)
For iLoop = 1 To nUsed
Debug.Print oRow.Cells(1, iLoop)
' assign oRow.Cells(1,iLoop) to something else here
Next iLoop
Next oRow
End Sub
As per your question I am assuming that you want to copy a complete row having blank cells to another location(row) but without blank cells.
I guess this is what you want.
Sub CountNonBlankCells()
Dim CurrentSh As Worksheet, TargetSh As Worksheet
Dim LastColumn As Long, count As Long
Dim MyRange As Range
Dim i As Long, temp As Long
Dim RowNum As Long
Set CurrentSh = ThisWorkbook.Worksheets("Sheet1")
Set TargetSh = ThisWorkbook.Worksheets("Sheet2")
RowNum = ActiveCell.Row
LastColumn = CurrentSh.Cells(RowNum, Columns.count).End(xlToLeft).Column
Set MyRange = CurrentSh.Rows(RowNum)
count = WorksheetFunction.CountA(MyRange)
temp = 1
For i = 1 To LastColumn
If Not IsEmpty(CurrentSh.Cells(RowNum, i)) Then
TargetSh.Cells(RowNum, temp).Value = CurrentSh.Cells(RowNum, i).Value
temp = temp + 1
End If
Next i
End Sub
Above code will copy active row in Sheet1 to Sheet2 at same row number without blank cells.

Excel - Move rows containing an empty cell to another sheet

This is my first attempt at VBA, so I apologize for my ignorance. The situation is as follows: I have a spreadsheet that consists of 4 columns and 629 rows. When I am trying to do is iterate through the 4 cells in each row and check for a blank cell. If there is a row that contains a blank cell, I want to cut it from Sheet1 and paste it into the first available row in Sheet2.
(Ideally the number of columns AND the number of rows is dynamic based on each spreadsheet, but I have no idea how to iterate through rows and columns dynamically)
Sub Macro1()
'
' Macro1 Macro
' Move lines containing empty cells to sheet 2
'
' Keyboard Shortcut: Ctrl+r
'
Dim Continue As Boolean
Dim FirstRow As Long
Dim CurrentRow As Long
Dim LastRow As Long
Dim EmptySheetCount As Long
Dim Counter As Integer
'Initialize Variables
LContinue = True
FirstRow = 2
CurrentRow = FirstRow
LastRow = 629
EmptySheetCount = 1
'Sheets(Sheet1).Select
'Iterate through cells in each row until an empty one is found
While (CurrentRow <= LastRow)
For Counter = 1 To 4
If Sheet1.Cells(CurrentRow, Counter).Value = "" Then
Sheet1.Cells(CurrentRow).EntireRow.Cut Sheet2.Cells(EmptySheetCount, "A")
EmptySheetCount = EmptySheetCount + 1
Counter = 1
CurrentRow = CurrentRow + 1
GoTo BREAK
Else
Counter = Counter + 1
End If
Counter = 1
BREAK:
Next
Wend
End Sub
When I run it, I typically get an error around the Sheet1.Cells(CurrentRow, Counter).Value = "" area, so I know I'm referencing sheets incorrectly. I've tried Sheets(Sheet1), Worksheets("Sheet1") and nothing seems to be working. When I do change to Worksheets("Sheet1"), however, it runs and just freezes Excel.
I know I'm doing multiple things wrong, I just know way too little to know what.
Thanks a lot in advance. And sorry for the crap formatting.
There are a few things wrong with your code so rather than go through them individually here is a basic looping version that does what you're after.
Sub moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Dim lastColumn As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Set wksData = Worksheets("Sheet1")
Set wksDestination = Worksheets("Sheet2")
destinationRow = 1
lastColumn = wksData.Range("XFD1").End(xlToLeft).Column
lastRow = wksData.Range("A1048576").End(xlUp).Row
For i = lastRow To 1 Step -1 'go 'up' the worksheet to handle 'deletes'
For j = 1 To lastColumn
If wksData.Cells(i, j).Value = "" Then 'check for a blank cell in the current row
'if there is a blank, cut the row
wksData.Activate
wksData.Range(Cells(i, 1), Cells(i, lastColumn)).Cut
wksDestination.Activate
wksDestination.Range(Cells(destinationRow, 1), Cells(destinationRow, lastColumn)).Select
ActiveSheet.Paste
'If required this code will delete the 'cut' row
wksData.Rows(i).Delete shift:=xlUp
'increment the output row
destinationRow = destinationRow + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next j
Next i
set wksData = Nothing
set wksDestination = Nothing
End Sub
There are other ways that will achieve the same outcome but this should give you and idea of how to use loops, sheets, ranges, etc.
The lastColumn and lastRow variables will find the the last column/row of data in the given columns/rows (i.e, in my code it finds the last column of data in row 1, and the last row of data in column A).
Also, you should get into the habit of debugging and stepping through code to identify errors and see exactly what each line is doing (this will also help you learn too).
You might find this of use.
It uses an array variable to store the values of the cells in the row to be moved. It does not use cut and paste, so only transfer the data values, and the code does not require activation of the required sheets.
The destination rows are in the same order as the rows on the original sheet.
The method used to find the last cell used in the row and column is more elegant than other answers given.
Option Explicit
Public Sub test_moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Set wksData = shtSheet1 ' Use the Codename "shtSheet1" for the worksheet. ie the value of the sheet property that is displayed as "(Name)"
Set wksDestination = shtSheet2
moveData wksData, wksDestination
End Sub
Public Sub moveData(wksData As Worksheet, wksDestination As Worksheet)
Dim ilastColumn As Integer
Dim ilastRow As Integer
Dim iRow As Long
Dim iColumn As Long
Dim iDestinationRowNumber As Integer
Dim MyArray() As Variant
Dim rngRowsToDelete As Range
iDestinationRowNumber = 1
ilastColumn = wksData.Cells(1, wksData.Columns.Count).End(xlToLeft).Column
ilastRow = wksData.Cells(wksData.Rows.Count, 1).End(xlUp).Row
ReDim MyArray(1, ilastColumn)
Set rngRowsToDelete = Nothing
For iRow = 1 To ilastRow Step 1 'No need to go 'up' the worksheet to handle 'deletes'
For iColumn = 1 To ilastColumn
If wksData.Cells(iRow, iColumn).Value = "" Then 'check for a blank cell in the current row
MyArray = wksData.Range(wksData.Cells(iRow, 1), wksData.Cells(iRow, ilastColumn)).Value
wksDestination.Range(wksDestination.Cells(iDestinationRowNumber, 1),
wksDestination.Cells(iDestinationRowNumber, ilastColumn) _
).Value = MyArray
'Store the rows to be deleted
If rngRowsToDelete Is Nothing Then
Set rngRowsToDelete = wksData.Rows(iRow)
Else
Set rngRowsToDelete = Union(rngRowsToDelete, wksData.Rows(iRow))
End If
'increment the output row
iDestinationRowNumber = iDestinationRowNumber + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next iColumn
Next iRow
If Not rngRowsToDelete Is Nothing Then
rngRowsToDelete.EntireRow.Delete shift:=xlUp
End If
Set rngRowsToDelete = Nothing
Set wksData = Nothing
Set wksDestination = Nothing
End Sub
' enjoy

Excel expression to copy rows but remove blank rows

I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps

Resources