I have some code in which I am trying to sort the data set in a csv file based on the content of a cell in another (the main) workbook. Then based on this sort, copy a range of visible cells between the first and sixth columns, but with a dynamic last row thus the range will be dynamic. This dynamic range is then pasted into the main sheet, which will then allow me to do further work on this dataset.
Can't seem to get the sort to work or the dynamic range working. I've tried all sorts of variation on the code below and am looking for some inspiration.
Sub Get_OA_Data()
'Find OA data from source SQL file and copy into serial number generator
Dim ws As Worksheet
Dim wkb2 As Workbook
Dim ws2 As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
'This section sets the workbooks and worksheets to be used for this macro
Set ws = ThisWorkbook.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srvabdotfpr08\PC_APPS\forum\Gateshead Serialisation\sys_serialisation1.csv")
Set ws2 = wkb2.Worksheets("sys_serialisation1")
Set rng2 = ws.Range("F6")
' This line deletes any content of the cannot assign serial number added previously
ws.Range("I6:I7").ClearContents
'This hides all rows which do not match the desired OA number (found in rng2)
For Each Cell In ws2.Range("A1").End(xlDown)
If Left(Cell.Value, 6) <> rng2.Value Then
Cell.EntireRow.Hidden = True
End If
Next Cell
Set StartCell = ws2.Range("A1")
LastRow = StartCell.SpecialCells(xlCellTypeVisible).Row
LastColumn = StartCell.SpecialCells(xlCellTypeVisible).Column
'This section selects and copies the visible range from csv file into serialisation generator
Set rng = ws2.Range(StartCell.ws2.Cells(LastRow, LastColumn))
rng.Copy
ws.Activate
ws.Range("D12").Select
Selection.PasteSpecial 'Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Any help would be greatly appreciated, I've bought a couple of books, but none of the stuff in my books is helping with this issue.
P.S I have used very similar code with specific set ranges and it works fine, but this one has me stumped. There may also be an issue with the dataset- which is why I have the LEFT formula in the code (but this seems to work OK).
Try...
Option Explicit
Sub Get_OA_Data()
Dim wkb2 As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim rng As Range, xCell As Range
Dim LR As Long, LC As Long, LR2 As Long
Set ws = ThisWorkbook.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srvabdotfpr08\PC_APPS\forum\Gateshead Serialisation\sys_serialisation1.csv")
Set ws2 = wkb2.Worksheets("sys_serialisation1")
ws.Range("I6:I7").ClearContents
LR2 = ws2.Range("A" & ws.Rows.Count).End(xlUp).Row
For Each xCell In ws2.Range("A1:A" & LR2)
xCell.EntireRow.Hidden = Left(xCell.Value, 6) <> ws.Range("F6")
Next xCell
LR = ws2.Range("A" & ws.Rows.Count).End(xlUp).Row
LC = ws2.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set rng = ws2.Range(ws2.Cells(1, 1), ws2.Cells(LR, LC))
rng.SpecialCells(xlCellTypeVisible).Copy
ws2.Range("D12").PasteSpecial xlPasteValues
End Sub
Related
I have a large range of cells that I am trying to select easily because it is too large to manually select and copy every time. I am looking for a way to quickly locate the entire range of data and select it. Not to be confused with only selecting every non-empty cell. There are cells within the big range that could be empty, but I also want to include them.
Example is my photo. I want to discover and select all the data that is A1:E7, including the cells in the middle that may be empty. If possible, I would want to de-select the heading as well and only select A2:E7.
So far I have managed to select everything with:
Range("A1").CurrentRegion.Select
But I am unsure how to de-select the top row after that.
Try this
Sub selectWithoutHeaders()
With Range("A1").CurrentRegion
.Offset(1, 0).Resize(.Rows.Count - 1).Select
End With
End Sub
You can use the handy UsedRange to determine the filled area on the sheet without checking each row and column for their last cell coordinates.
With UsedRange, you create a range stretching from A2 to the last cell, and then select it.
Sub Example()
Dim WS As Worksheet
Set WS = ActiveSheet
Dim LastCell As Range
With WS.UsedRange
Set LastCell = .Cells(.Rows.Count, .Columns.Count)
End With
WS.Range("A2", LastCell).Select
End Sub
Here is the Range(Cells(2, 1), Cells(LastRow, LastColumn)).Select version.
Public Function GetLastRowOfSheet(ws As Worksheet) As Long
Dim usedRng As Range
Dim lastRow As Range
Set usedRng = ws.UsedRange
Set lastRow = usedRng.Rows(usedRng.Rows.Count).EntireRow
GetLastRowOfSheet = lastRow.row
End Function
Public Function GetLastColOfSheet(ws As Worksheet) As Long
Dim usedRng As Range
Dim lastRow As Range
Set usedRng = ws.UsedRange
Set lastCol = usedRng.Columns(usedRng.Columns.Count).EntireColumn
GetLastColOfSheet = lastCol.Column
End Function
Sub SelectAllCells()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim lastRow As Long: lastRow = GetLastRowOfSheet(ws)
Dim lastCol As Long: lastCol = GetLastColOfSheet(ws)
Range(Cells(2, 1), Cells(lastRow, lastCol)).Select
End Sub
i have the below code to filter from a sheet the yellow cells in column A and copy them on another sheet at the bottom of the values already present in the column A, however also the header is beeing copied and i need to exclude it, what's wrong in your opinion?
Sub CopyColor()
Dim wk As Workbook: Set wk = ThisWorkbook
Dim sht As Worksheet: Set sht = wk.Worksheets("Base Dati Old")
Dim sht1 As Worksheet: Set sht1 = wk.Worksheets("Prova")
Dim lr, lr1 As Long, rng As Range
'Define last used row;
lr = sht.Cells(sht.Rows.count, "A").End(xlUp).Row
lr1 = sht1.Cells(sht1.Rows.count, "A").End(xlUp).Row
Set rng = sht.Range("A2:A" & lr)
'Filter your data on yellow;
rng.AutoFilter 1, RGB(255, 255, 0), xlFilterCellColor
'Copy filtered cells;
rng.SpecialCells(12).Offset.Copy wk.Worksheets("Prova").Range("A" & lr1)
'Turn off filter
rng.AutoFilter
End Sub
Try this:
rng.Offset(1,0).Resize(rng.Rows.count-1).SpecialCells(12).Copy _
wk.Worksheets("Prova").Range("A" & lr1)
Dim lastrow As Long, lastrow2 As Long
Dim wksSource As Worksheet, wksDest As Worksheet
Dim source1 As Range, target1 As Range, source2 As Range, target2 As Range
Set wksSource = Workbooks("2021 Tracker.xlsm").Worksheets("Sheet3")
Set wksDest = Workbooks("Jan Tracker).xlsm").Worksheets("Sheet1")
lastrow = wksSource.Cells(Rows.Count, 1).End(xlUp).row
lastrow2 = wksDest.Cells(Rows.Count, 1).End(xlUp).Offset(1,0).row
Set source1 = wksSource.Range("A2:A" & lastrow)
Set source2 = wksSource.Range("B2:B" & lastrow)
Set target1 = wksDest.Range("E" & lastrow2)
Set target2 = wksDest.Range("F" & lastrow2)
source1.Copy: target1.PasteSpecial Paste:=xlPasteValues
source2.Copy: target2.PasteSpecial Paste:=xlPasteValues
This code replaces data in columns E and F of destination workbook, but i want it to append to it. Please help.
Your code determines the next row in column A of the destination worksheet: lastrow2 = wksDest.Cells(Rows.Count, 1).End(xlUp).Offset(1,0).Row. But you are pasting to columns E and F. Therefore the last row in column A doesn't change and that results in over-writing.
I have re-written your code to make it more transparent. I think this kind of syntax will make it easier for you to spot errors like the one that you asked about. It may take a little more time to set up but the time is well invested.
Sub AppendData()
Dim wksSource As Worksheet ' Source sheet
Dim wksTarget As Worksheet ' Target sheet
Dim Source1 As Range
Dim Target As Range
Dim Rl As Long ' last row
Set wksSource = Workbooks("2021 Tracker.xlsm").Worksheets("Sheet3")
With wksSource
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Source = .Range(.Cells(2, "A"), .Cells(Rl, "B"))
End With
Set wksTarget = Workbooks("Jan Tracker).xlsm").Worksheets("Sheet1")
With wksTarget
Set Target = .Cells(.Rows.Count, "E").End(xlUp).Offset(1)
End With
Source.Copy Deestination:=Target
Application.CutCopyMode = False
End Sub
I have written a code in which I try to copy and paste several ranges of data from one worksheet to the other, but I want to copy the data below the previous set of data. The code I used for the copy entries is this part:
Selection.Copy
Windows(Workbook1).Activate
Sheets(Sheet1).Select
Cells(Rows.Count, 1).End(x1Up).Select
ActiveCell.PasteSpecial xlPasteValues
I get the error on the 4th row
(Application Defined or object Defined error).
Your code can be condensed using the example from https://learn.microsoft.com/en-us/office/vba/api/excel.range.copy:
Worksheets("Sheet1").Range("A1:D4").Copy destination:=Worksheets("Sheet2").Range("E5")
Applied to your work:
Dim lRow As Long
Dim wb As Workbook: Set wb = ThisWorkbook
Dim Sourcews As Worksheet: Set Sourcews = wb.Worksheets("Sheet21")
Dim Destinationws As Worksheet: Set Destinationws = wb.Worksheets("Sheet1")
lRow = Destinationws.Cells(Destinationws.Rows.Count, "A").End(xlUp).Row + 1
Sourcews.Range("A1:D4").Copy Destination:=Destinationws.Range("A" & lRow)
Avoid using activate and select. It is slow and can be unreliable.
Try this code, please. It will copy the selected range values in the last empty row of column A:A. I deduced that from your way of trying to calculate. But, you did that in an incorrect way. You would copy your range over the "A1:A" & last cell range. Is that what you really want?
Sub testCopyValues()
Dim sh As Worksheet, lastRow As Long, rng As Range
Set rng = Selection
Set sh = Workbooks("Workbook1").Sheets(1)
lastRow = sh.Cells(Rows.count, 1).End(xlUp).row
sh.Range("A" & lastRow + 1).Resize(rng.Rows.count, rng.Columns.count).Value = rng.Value
End Sub
If you need to paste on another sheet of the same workbook, please replace
Set sh = Workbooks("Workbook1").Sheets(1) with Set sh = ActiveWorkbook.Sheets(1)
I'm wanting to use VBA to copy a range of data from one workbook and paste it in another workbook. To know where to paste the information, I search for the next empty row.
The code works successfully until the last portion when trying to copypaste values. I do not get any errors, or any indication of success or failure. I can see it being copied correctly (the marching dots), and the correct cell is selected, but nothing is pasted.
Sub Button1_Click()
Dim wb1 As Workbook
Dim sht As Worksheet
Dim rng As Range
Dim databasewb As Workbook
Dim databasesht As Worksheet
Dim eRow As Integer
'set workbooks to variables
Set databasewb = Workbooks("Aged Debt Data V1.xlsm")
Set wb1 = Workbooks.Open("C:\Users\roanderson\Desktop\Aged debt\Templates\BIO Inc (IO) Template.xlsx")
'select sheet where data lies
Set sht = wb1.Sheets("Conversion to aged debt format")
sht.Activate
'copy range on sheet
Set rng = sht.Range("A2", Range("A2").End(xlDown).End(xlToRight))
rng.Copy
' paste range into database
'activate database workbook
databasewb.Activate
'find next empty row
eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
MsgBox (eRow)
'paste values into empty row
Sheet1.Cells(eRow, 1).Select
rng.PasteSpecial Paste:=xlPasteValues
wb1.Close
End Sub
The data to be pasted in the Datebase workbook,
When possible, try to avoid using Copy Paste with VBA, as well as avoid using select. Since you just want to copy values, using VBA's Value approach would likely be easier. Modify your line of code where you try to paste special to setting the value. See below
'paste values into empty row
Sheet1.Cells(eRow, 1).Resize(RNG.Rows.Count, RNG.Columns.Count).Value = RNG.Value
wb1.Close
What this is doing starting in Cells(erow,1) the code is using Resize to set the starting range to be the same number of rows and columns or your variable RNG. Then it's just setting the values, the same result as CopyPasteValue only less overhead.
However, if you did want to keep the approach of Copy paste value, then modify your code as such:
'paste values into empty row
Sheet1.Cells(eRow, 1).PasteSpecial Paste:=xlPasteValues
wb1.Close
Change rng.pastespecial to
selection.pastespecial
Performance improvement for copy-paste values. Modular sub.
Bypassing the clipboard is recommended for just Pasting Values. PasteSpecial is less efficient.
See section 8: https://techcommunity.microsoft.com/t5/excel/9-quick-tips-to-improve-your-vba-macro-performance/m-p/173687
Sub CopyPasteSingleCol pastes to PasteFirstRow for Single Column.
sub CopyPasteSingleCol2firstBlank pastes after last blank in column for Single Column.
Sub CopyPasteSingleCol(SrcSheet As Worksheet, ByVal SrcCol As String, ByVal SrcFirstRow As Long, _
PasteSheet As Worksheet, ByVal PasteCol As String, ByVal PasteFirstRow As Long)
Dim SrcLastRow As Long
Dim PasteLastrow As Long
Dim SrcRng As Range
Dim PasteRng As Range
SrcLastRow = SrcSheet.Cells(SrcSheet.Rows.Count, SrcCol).End(xlUp).Row
Set SrcRng = SrcSheet.Range(SrcCol & SrcFirstRow & ":" & SrcCol & SrcLastRow)
Set PasteRng = PasteSheet.Range(PasteCol & PasteFirstRow)
SrcRng.Copy PasteRng
End Sub
Sub CopyPasteSingleCol2firstBlank(SrcSheet As Worksheet, ByVal SrcCol As String, ByVal SrcFirstRow As Long, _
PasteSheet As Worksheet, ByVal PasteCol As String)
Dim SrcLastRow As Long
Dim PasteLastrow As Long
Dim SrcRng As Range
Dim PasteRng As Range
SrcLastRow = SrcSheet.Cells(SrcSheet.Rows.Count, SrcCol).End(xlUp).Row
PasteLastrow = PasteSheet.Cells(PasteSheet.Rows.Count, PasteCol).End(xlUp).Row + 1
' If first row is empty there was not need to add +1 to Lastrow
If PasteSheet.Cells(1, PasteCol) = vbNullString Then PasteLastrow = 1
Set SrcRng = SrcSheet.Range(SrcCol & SrcFirstRow & ":" & SrcCol & SrcLastRow)
Set PasteRng = PasteSheet.Range(PasteCol & PasteLastrow)
SrcRng.Copy PasteRng
End Sub
Sub TESTCopyPasteSingleCol()
Dim SrcSheet As Worksheet
Dim PasteSheet As Worksheet
'Must qualify your Sheet by using Set before calling sub
Set SrcSheet = Workbooks("importGsheettoExcel3.xlsm").Worksheets("SH1")
Set PasteSheet = Workbooks("importGsheettoExcel.xlsm").Worksheets("SH2")
Call CopyPasteSingleCol(SrcSheet, "B", 2, _
PasteSheet, "G", 2)
End Sub
Sub TESTCopyPasteSingleCol2firstBlank()
Dim SrcSheet As Worksheet
Dim PasteSheet As Worksheet
'Must qualify your Sheet by using Set before calling sub
Set SrcSheet = Workbooks("importGsheettoExcel3.xlsm").Worksheets("SH1")
Set PasteSheet = Workbooks("importGsheettoExcel.xlsm").Worksheets("SH2")
Call CopyPasteSingleCol2firstBlank(SrcSheet, "B", 2, _
PasteSheet, "G")
End Sub