Copy sheet data to the end of another sheet - vba

I am able to copy the last row of one workbook and paste it after the last row of another workbook. I want to copy the entire data from row 2 (row 1 is header) in the first workbook and paste it after the last row of another workbook. Please advise me what changes are required in the code below to copy the entire data from row 2 instead of only the last row.
Dim lastS1Row As Long
Dim nextS2Row As Long
Dim lastCol As Long
Dim lCol As Long
Dim lCol1 As Long
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim path1 As String
source = "Students" 'Source Worksheet Name
path1 = "H:\Shaikh_Gaus\scratch\VBA\Book17.xlsx"
path = "H:\Shaikh_Gaus\scratch\VBA\Book16.xlsx"
target = "Students" 'Target Worksheet Name
Application.EnableCancelKey = xlDisabled
Set s1Sheet = Workbooks.Open(path).Sheets(source)
Set s2Sheet = Workbooks.Open(path1).Sheets(target)
lastS1Row = s1Sheet.Range("A" & Rows.Count).End(xlUp).Row
nextS2Row = s2Sheet.Range("A" & Rows.Count).End(xlUp).Row + 1
lastCol = s1Sheet.Cells(1, Columns.Count).End(xlToLeft).Column
For lCol = 1 To lastCol
s2Sheet.Cells(nextS2Row, lCol) = s1Sheet.Cells(lastS1Row, lCol)
Next lCol
Next lCol1
s2Sheet.Activate
ActiveWorkbook.Close SaveChanges:=True
s1Sheet.Activate
ActiveWorkbook.Close

This adjusted version of your code should do the job:
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim path1 As String
Dim rngSource As Range
Dim rngTargetStart As Range
source = "Students" 'Source Worksheet Name
path1 = "H:\Shaikh_Gaus\scratch\VBA\Book17.xlsx"
path = "H:\Shaikh_Gaus\scratch\VBA\Book16.xlsx"
target = "Students" 'Target Worksheet Name
Application.EnableCancelKey = xlDisabled
Set s1Sheet = Workbooks.Open(path).Sheets(source)
Set s2Sheet = Workbooks.Open(path1).Sheets(target)
Set rngSource = Range(s1Sheet.Range("A2"), s1Sheet.Cells.SpecialCells(xlCellTypeLastCell))
Set rngTargetStart = s2Sheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
rngTargetStart.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value
s2Sheet.Parent.Close SaveChanges:=True
s1Sheet.Parent.Close
I removed something what seemed unnecessary. The main thing is that now you don't loop through columns and rows. Now you can do it with one operation.
Avoid as much as you can things like .Select, .Activate. and .Copy if you just need values to be pasted. You can simply do something similar like I did:
Target.Value = Source.Value

After you set s1Sheet and s2Sheet I think you should be able to use these 2 lines to copy & paste the entire range at once:
'copy Cells A2 through last row and last column used
s1Sheet.Range(s1Sheet.Cells(2, 1), s1Sheet.Cells(s1Sheet.Cells(s1Sheet.Rows.Count, 1).End(xlUp).Row, _
s1Sheet.Cells(1, s1Sheet.Columns.Count).End(xlToLeft).Column)).Copy
'paste those cells in next blank row of second sheet
s2Sheet.Cells(s2Sheet.Cells(s2Sheet.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll

'Here you go:
Range("A2").End(xlDown).select
selection.End(xlRight).select
selection.copy
'then active the next sheet for e.g Sheet2.Active
last_row = range("A1048576").end(xlup).row
range("A" & last_row).paste
' Done

Related

Extracting data from one workbook and pasting in another with comments

I would like to copy the data from one workbook to another.
My source workbook has some comments listed in each row. When I use my code to copy, it does not copy the comments accordingly. Could any one help, how I could copy from one workbook to another with the comment field ? my comments are in Column P.
Sub Extract()
Dim DestinationWB As Workbook
Dim OriginWB As Workbook
Dim path1 As String
Dim FileWithPath As String
Dim lastRow As Long, i As Long, LastCol As Long
Dim TheHeader As String
Dim cell As Range
Set DestinationWB = ThisWorkbook
path1 = DestinationWB.Path
FileWithPath = path1 & "\Downloads\CTT.xlsx"
Set OriginWB = Workbooks.Open(filename:=FileWithPath)
lastRow = OriginWB.Worksheets("Report").Cells(Rows.count, 1).End(xlUp).Row
LastCol = OriginWB.Worksheets("Report").Cells(22, Columns.count).End(xlToLeft).Column
For i = 1 To LastCol
'get the name of the field (names are in row 22)
TheHeader = OriginWB.Worksheets("Report").Cells(22, i).Value
With DestinationWB.Worksheets("CTT").Range("A4:P4")
'Find the name of the field (TheHeader) in the destination (in row 4)
Set cell = .Find(TheHeader, LookIn:=xlValues)
End With
If Not cell Is Nothing Then
OriginWB.Worksheets("Report").Range(Cells(23, i), Cells(lastRow, i)).Copy Destination:=DestinationWB.Worksheets("CTT").Cells(5, cell.Column)
Else
'handle the error
End If
Next i
OriginWB.Close SaveChanges:=False
End Sub
I refactored your code correcting the unqualified references and printing the Source and Destination range addresses to the Immediate window. This should give you an idea of what is going on.
Sub Extract()
Dim DestinationWB As Workbook
Dim OriginWB As Workbook
Dim FileWithPath As String, path1 As String, TheHeader As String
Dim lastRow As Long, col As Long
Dim cell As Range, Source As Range
Set DestinationWB = ThisWorkbook
path1 = DestinationWB.Path
FileWithPath = path1 & "\Downloads\CTT.xlsx"
Set OriginWB = Workbooks.Open(Filename:=FileWithPath)
With OriginWB.Worksheets("Report")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For col = 1 To .Cells(22, .Columns.Count).End(xlToLeft).Column
'get the name of the field (names are in row 22)
TheHeader = OriginWB.Worksheets("Report").Cells(22, col).Value
With DestinationWB.Worksheets("CTT").Range("A4:P4")
'Find the name of the field (TheHeader) in the destination (in row 4)
Set cell = .Find(TheHeader, LookIn:=xlValues)
End With
If Not cell Is Nothing Then
Set Source = .Range(.Cells(23, col), .Cells(lastRow, col))
Source.Copy Destination:=cell.Offset(1)
Debug.Print Source.Address(External:=True), "Copied to ", cell.Offset(1).Address(External:=True)
Else
'handle the error
End If
Next
End With
OriginWB.Close SaveChanges:=False
End Sub

Copy data from one workbook to another workbook based on critera

I tried to copy data from one workbook to another workbook based on some criteria. The macro is written in the destination workbook as below.
However when I run the code, i get an "Runtime Error 9. Script out of range error". Can anyone help me take a look of the code? Thanks!!!!
Sub sbCopyRangeToAnotherSheetFromLastRow()
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim path1 As String
Dim rngSource As Range
Dim rngTargetStart As Range
Dim rngTargetStart2 As Range
Dim j As Long, k As Long, erow As Integer
source = "PB Position" 'Source Tab Name
path_source = "C:\Temp\MIS RISK REPORT.xlsm"
target = "Input - Trailing 12 week" 'Target tab Name
Application.EnableCancelKey = xlDisabled
Set s1Sheet = Workbooks.Open(path_source).Sheets(source)
Set s2Sheet = ThisWorkbook.Sheets(target)
Set rngSource = Range(s1Sheet.Range("A8"), s1Sheet.Cells.SpecialCells(xlCellTypeLastCell))
Set rngTargetStart = s2Sheet.Range("C" & Rows.Count).End(xlUp).Offset(1)
k = rngSource.Rows.Count
For j = 8 To k
If (rngSource.Cells(j, "O") = "K1" Or rngSource.Cells(j, "O") = "K2" Or rngSource.Cells(j, "O") = "G2") And rngSource.Cells(j, "AH") <> 1 Then
rngSource.Cells(j, "A").EntireRow.Select
Selection.Copy
Worksheets(target).Select
erow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, "C").Select
ActiveSheet.Paste
ActiveWorkbook.Save
Application.CutCopyMode = False
End If
Next j
End Sub
I was about to write a third comment, so I'll lump all my advice into an answer and hopefully this clean-up will fix your problems.
1) Your Set rngSource row should read
s1Sheet.Range("A8", s1Sheet.Cells.SpecialCells(xlCellTypeLastCell))
That may not be the problem here but it actually targets the range you want I think!
2) You should also avoid using Select (see this previous SO question). Instead, first calculate erow, then use
rngSource.Cells(j, "A").EntireRow.copy destination:= ActiveSheet.Cells(erow,"C")
Except that you can't paste an entire row into a cell in column C! It should actually be
rngSource.Cells(j, "A").EntireRow.copy destination:= ActiveSheet.Cells(erow,"A")
THIS may be where your out of range error is coming from

VBA loop throught cells and extract the file name from cells in excel sheet

I have an excel sheet that in each cell in column A , the path of a source folder :
column A
P:\Desktop\Source\Test1-folder\file1.txt
P:\Desktop\Source\Test1-folder\file2.txt
and i want to take just the file name (file1.txt) for each file , how can i do it ? Can you help me please ?
For Each oFolder In oSourceFolder.SubFolders
lastcol = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
For Each oFile In oFolder.Files
If Dir(destinationFolder, 16) = "" Then MkDir (destinationFolder)
For k = 1 To dercol
numrows = worksh.Cells(Rows.Count, icol).End(xlUp).Row
For w = 2 To numrows
filepath = worksh.Cells(w, icol).Value
But this one loops through the files, not the cells. How can I loop through the cells?
Try this:
' Get the sheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
' How you will slash it
Dim strSlash As String
strSlash = "\"
' Set the range for your tool
Dim rngFiles As Range
Dim rngCell As Range
Dim lngMaxRow As Long
lngMaxRow = Range("A" & Rows.Count).End(xlUp).Row
Set rngFiles = Range("A1:A" & lngMaxRow)
' Grab it from the rear
For Each rngCell In rngFiles.Cells
Debug.Print Right(rngCell.Value, Len(rngCell.Value) - InStrRev(rngCell.Value, strSlash))
Next
If all you want is the file name, you can do this with a simple worksheet formula:
=TRIM(RIGHT(SUBSTITUTE(A1,"\",REPT(" ",99)),99))

Copy from another workbooks the last row with value to the active workbook

I got 35 files and a master one. In the files , Sheet1, column D has the values 480 and 0. How can i copy the last row ( from all the 35 files ) that has 480 in column D in the master file Sheet3 ? Until now i have used the code for copy the last row but i can't make it to search the column D for value then copy. I really want to run the macro from the master not from the many files (now actually a made a macro to open all the files and run macro cop to copy the last rows but now i must copy only the last row that has 480 value in column D ).Thank you.
Sub cop()
Dim lastS1Row As Long
Dim nextS2Row As Long
Dim lastCol As Long
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim DestLast As Long
source = "Sheet1"
path = "C:\Users\me\Desktop\2.xlsx"
target = "Sheet3"
Application.EnableCancelKey = xlDisabled
Set s1Sheet = ThisWorkbook.Sheets(source)
Set s2Sheet = Workbooks.Open(path).Sheets(target)
lastS1Row = s1Sheet.Range("A" & Rows.Count).End(xlUp).Row
nextS2Row = s2Sheet.Range("A" & Rows.Count).End(xlUp).Row + 1
lastCol = s1Sheet.Cells(1, Columns.Count).End(xlToLeft).Column
For lCol = 1 To lastCol
s2Sheet.Cells(nextS2Row, lCol) = s1Sheet.Cells(lastS1Row, lCol)
Next lCol
s2Sheet.Activate
ActiveWorkbook.Close SaveChanges:=True
s1Sheet.Activate
End Sub
Try this. I'm assuming the 480 is a number and not a string. I added an If-Then to check if last row, column D is equal to 480.
Sub cop()
Dim lastS1Row As Long
Dim nextS2Row As Long
Dim lastCol As Long
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim DestLast As Long
source = "Sheet1"
path = "C:\Users\me\Desktop\2.xlsx"
target = "Sheet3"
Application.EnableCancelKey = xlDisabled
Set s1Sheet = ThisWorkbook.Sheets(source)
Set s2Sheet = Workbooks.Open(path).Sheets(target)
lastS1Row = s1Sheet.Range("A" & Rows.Count).End(xlUp).row
nextS2Row = s2Sheet.Range("A" & Rows.Count).End(xlUp).row + 1
lastCol = s1Sheet.Cells(1, Columns.Count).End(xlToLeft).Column
If (s1Sheet.Cells(lastS1Row, 4).Value = 480) Then ' This is where you check the last row, column D.
For lCol = 1 To lastCol
s2Sheet.Cells(nextS2Row, lCol) = s1Sheet.Cells(lastS1Row, lCol)
Next lCol
End If
s2Sheet.Activate
ActiveWorkbook.Close SaveChanges:=True
s1Sheet.Activate
End Sub

VBA copy row from one sheet to another based on 2 criteria

i have 2 sheeets. basically ws1 is the destination, ws2 is the source. then i have 2 criterias, an ID Number, and a name of the person who will work on the ID Number.
source contains a row with new actions/progress done by "working person" and need to paste it on the destination in order to update it.
I've read around and saw that autofilter looks like the way to go. i have a code here that autofilters, but i'm just not sure how i can "attack" the problem.
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastrowDest As Long, currow As Long, lastrowSrc As Long
Dim critvalue1 As String
'Destination sheet (dashboard)
Set ws1 = Sheets("Destination")
'Source Sheet (source)
Set ws2 = Sheets("Source")
lastrowSrc = ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
lastrowDest = ws1.Range("A" & Rows.Count).End(xlUp).Row
For currow = 2 To lastrowSrc
critvalue1 = ws2.Range("E" & currow).Value
ws1.Range("A1").AutoFilter field:=5, Criteria1:=critvalue1
Next currow
end sub
is there an easy way to copy the row from source to destination provided that the IDnumber matches? (the IDnumber is unique)
the code above filters but i'm not sure of how to copy or move the rows.
thanks in advance.
This could be done with SUMPRODUCT or VLOOKUP but if you are set on VBA then try this
Sub copyRow()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastrowDest As Long, currowSrc As Long, currowDest As Long, lastrowSrc As Long
Dim critvalue1 As String
Set ws1 = Sheets("Sheet2")
Set ws2 = Sheets("Sheet1")
lastrowSrc = ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
lastrowDest = ws1.Range("A" & Rows.Count).End(xlUp).Row
For currowSrc = 2 To lastrowSrc
critvalue1 = ws2.Range("E" & currowSrc).Value
ws2.Cells(6, 5).Value = critvalue1
For currowDest = 2 To lastrowDest
If ws1.Range("E" & currowDest).Value = critvalue1 Then
ws2.Rows(currowSrc).Copy Destination:=ws1.Range("A" & currowDest)
End If
Next currowDest
Next currowSrc
End Sub
I find it easier than dealing with the autofilter. It goes row by row from the source sheet and checks for a match in every row of the destination sheet. If there is a match, the source row in copied to the matching destination row.
To keep formatting instead of
ws2.Rows(currowSrc).Copy Destination:=ws1.Range("A" & currowDest)
use
ws2.Rows(currowSrc).Copy
ws1.Range("A" & currowDest).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
I pulled this out of a larger macro I use and made some changes to make it match your method a little better and I deleted some irrelevant stuff. The variable names are a bit different. I believe this does what you need. Let me know if it gives you trouble.
Don't forget to populate the ID and Name arrays, set the value for the 2 column variables and assign the sheet names before running.
Sub copyByAutofilter()
Dim filterList1 As Variant
filterList1 = Array("ID1", "ID2")
filterCol1 = 1 'or whatever column contains the IDs
Dim filterList2 As Variant
filterList2 = Array("Name1", "Name2")
filterCol2 = 2 'or whatever column contains the names
Dim sourceWB As String
sourceWB = ThisWorkbook.Name
Dim sourceWS As String
sourceWS = "Sheet2"
Dim destinationWB As String
destinationWB = ThisWorkbook.Name
Dim destinationWS As String
destinationWS = "Sheet3"
lastrowSrc = Sheets(sourceWS).Range("A" & Rows.Count).End(xlUp).Offset(1).Row
lastrowDest = Sheets(destinationWS).Range("A" & Rows.Count).End(xlUp).Row
Workbooks(sourceWB).Sheets(sourceWS).AutoFilterMode = False
Workbooks(sourceWB).Sheets(sourceWS).Range("$A$1:$O" & lastrowSrc).AutoFilter Field:=filterCol1, _
Criteria1:=filterList1, Operator:=xlFilterValues
Workbooks(sourceWB).Sheets(sourceWS).Range("$A$1:$O" & lastrowSrc).AutoFilter Field:=filterCol2, _
Criteria1:=filterList2, Operator:=xlFilterValues
Workbooks(sourceWB).Sheets(sourceWS).Range("A2:O" & lastrowSrc).SpecialCells _
(xlCellTypeVisible).Copy _
Destination:=Workbooks(destinationWB).Sheets(destinationWS).Cells(lastrowDest + 1, 1)
End Sub
One method is by using the Copy method of the Range object. This should generally be avoided though as this overwrites the clipboard. A safer option is to simply use rngDest.Value = rngSrc.Value. Note that for this to work the ranges must be the same size. Here is how this is normally used:
Dim dst As Range
Dim src As Range
Set src = Range("A1:B3") 'Data you want to copy
Set dst = Range("C1") 'First cell in the destination Range
Set dst = dst.Resize(src.Rows.Count, src.Columns.Count) 'Resize to match src
dst.Value = src.Value 'Copy to destination
This method has the benefit of preserving the clipboard!