I am trying to copy the content from a user opened worksheet to another worksheet from another Workbook. The code below do works, but it doesnt select the first empty cell from the WS_REL sheet, and overwrite all the data contained. So far, I have this:
Sub Importar_Dados()
Dim vTemp As Variant
Dim WB_TOA As Workbook, WB_REL As Workbook
Dim WS_TOA As Worksheet, WS_REL As Worksheet
Set WB_REL = ActiveWorkbook
Set WS_REL = WB_REL.Sheets("Planilha2")
vTemp = Application.GetOpenFilename("Excel-files,*.xlsx", _
1, "Selecione o relatório gerado pelo TOA", , False)
If TypeName(vTemp) = "Boolean" Then Exit Sub
Workbooks.Open vTemp
Set WB_TOA = Workbooks.Open(vTemp)
Set WS_TOA = WB_TOA.Sheets("Page 1")
WS_TOA.Cells.Copy WS_REL.Cells
End Sub
Thank you!
First, you dont need to open the other workbook twice. Remove the line
Workbooks.Open vTemp
Then, to append without overwriting, you need to find the last non-empty cell in your destination sheet. Try it like (for example):
WS_TOA.usedRange.Copy WS_REL.Range("A999999").End(xlUp).Offset(1)
If you dont have a column that is sure to have data in all rows, use this:
WS_TOA.usedRange.Copy WS_REL.Range("A" & WS_REL.Cells.Find("*", , , , xlByRows, xlPrevious).Row+1)
This finds you the first non-empty row.
Related
I am trying to copy all the used cells in an excel worksheet from a closed workbook into an already created worksheet in my current workbook using VBA.
Have seen lots of examples on copy the sheet as a new sheet but not just the used contents into an existing sheet.
Thanks!
Mike
Open the source workbook, using:
set wb = Workbooks.Open FileName:="fullPathAndFileName.xlsx", UpdateLinks:=0, ReadOnly:=True, AddToMru:=False
Using a reference to the sheet you want to copy, eg., wb.Sheets(1) (refers to the first sheet in the workbook), and a reference to your destination sheet, eg. destWorkSheet run a loop like this:
For Each cel in wb.Sheets(1).UsedRange.Cells
destWorkSheet.Cells(cel.Row, cel.Column) = cel
Next
This will copy the values cell by cell to the same location in the destination worksheet as they are in the source worksheet. You probably want to turn calculation off first. There are certainly other ways to do it as well.
You will still need to open the source workbook, but another approach is to do a direct write of Values. You can do this as long as the destination and source ranges are the same size and shape. This subroutine will do it for you:
Private Sub CopyValuesSourceToDest(src As Range, dest As Range)
'dest should be one cell, src can be a range of cells
If dest.Cells.Count <> 1 Then MsgBox "Only pass one cell as the destination.": Exit Sub
Dim rws As Long, cols As Long, trueDest As Range
rws = src.Rows.Count
cols = src.Columns.Count
Set trueDest = dest.Parent.Range(dest.Cells(1, 1), dest.Cells(1, 1).Offset(rws - 1, cols - 1))
trueDest.Value = src.Value
End Sub
You would then call the sub like this:
CopyValuesSourceToDest sourceSheet.UsedRange, destSheet.Range("B7") 'B7, or whatever
I'm not really great at coding so as much help as possible would be incredible. Basically here's what I want to do.
Export CSV from Website (No code required)
Open CSV in Excel (No code required)
Automatically remove rows that have a blank cell in certain column (Already coded)
Copy specific columns (ignoring header rows) to another workbook in specific order.
Column order is as follows: (S1 = Open CSV || S2 = New Workbook)
S1.V = S2.A
S1.B = S2.D
S1.F = S2.V
S1.H = S2.X
S1.I = S2.J
S1.L = S2.B
Step 3's code:
Columns("V:V").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
There is a lot to consider when doing what you require, I have made some assumptions that you will need to code for if they are incorrect: -
The destination already exists
The destination has headers on row 1 but no content
The destination is simply the first sheet in the destination workbook
The source header row is row 1
Sample code: -
Public Sub Sample()
Dim StrDestPath As String
Dim WkBk_Dest As Workbook
Dim WkBk_Src As Workbook
Dim WkSht_Dest As Worksheet
Dim WkSht_Src As Worksheet
'A reference to the destination
StrDestPath = "C:\Users\Gary\Desktop\Destination.xlsx"
'Connect to the source
Set WkBk_Src = ThisWorkbook
Set WkSht_Src = WkBk_Src.Worksheets(1)
'See if the destination is open already
For Each WkBk_Dest In Application.Workbooks
If WkBk_Dest.FullName = StrDestPath Then Exit For
Next
'If it wasn't then open it
If WkBk_Dest Is Nothing Then
Set WkBk_Dest = Application.Workbooks.Open(StrDestPath)
End If
'Connect to the destination
Set WkSht_Dest = WkBk_Dest.Worksheets(1)
'Per column mapping - Copy everythng from row 2 (assuming headers are on row 1 down to the last populated cell in that column
'and paste it into the required column in the destination
WkSht_Src.Range("V2:" & WkSht_Src.Range("V2").End(xlDown).Address).Copy WkSht_Dest.Range("A2")
WkSht_Src.Range("B2:" & WkSht_Src.Range("B2").End(xlDown).Address).Copy WkSht_Dest.Range("D2")
WkSht_Src.Range("F2:" & WkSht_Src.Range("F2").End(xlDown).Address).Copy WkSht_Dest.Range("V2")
WkSht_Src.Range("H2:" & WkSht_Src.Range("H2").End(xlDown).Address).Copy WkSht_Dest.Range("X2")
WkSht_Src.Range("I2:" & WkSht_Src.Range("I2").End(xlDown).Address).Copy WkSht_Dest.Range("J2")
WkSht_Src.Range("L2:" & WkSht_Src.Range("L2").End(xlDown).Address).Copy WkSht_Dest.Range("B2")
'Disconnect from destination worksheet
Set WkSht_Dest = Nothing
'save changes
WkBk_Dest.Save
'disconnect from destination workbook
Set WkBk_Dest = Nothing
'Disconnect from source
Set WkSht_Src = Nothing
Set WkBk_Src = Nothing
End Sub
I have also assumed the source to be the workbook I was coding in, this won't be possible in a CSV file so you might want to open it in the same way the destination is checked for and then opened, you also may want to add a flag to close them when done if they were not opened to begin with.
Finally, if the destination already has data use the .end function as shown in the sample to get the the last row.
since you're working from CSV file, you don't have formats to carry along
therefore simple values pasting is what you need
try this
Option Explicit
Sub CopyColumnsToAnotherWB(sourceWS As Worksheet, targetWs As Worksheet, sourceCols As String, targetCols As String)
Dim sourceColsArr As Variant, targetColsArr As Variant
Dim iCol As Long, nCols As Long
sourceColsArr = Split(Application.WorksheetFunction.Trim(sourceCols), ",") '<--| make array out of string with delimiter
targetColsArr = Split(Application.WorksheetFunction.Trim(targetCols), ",") '<--| make array out of string with delimiter
nCols = UBound(sourceColsArr) '<--| count columns number to copy/paste
If nCols <> UBound(targetColsArr) Then Exit Sub '<--| exit if the two columns list haven't the same number of columns
With sourceWS
For iCol = 0 To nCols '<--|loop through source sheet columns
With .Cells(1, sourceColsArr(iCol)).Resize(.Cells(.Rows.Count, sourceColsArr(iCol)).End(xlUp).Row)
targetWs.Columns(targetColsArr(iCol)).Resize(.Rows.Count).value = .value '<--|paste values to corresponding target sheet column
End With
Next iCol
End With
End Sub
which you can exploit as follows
Option Explicit
Sub main()
Dim sourceCols As String, targetCols As String
sourceCols = "V,B,F,H,I,L"
targetCols = "A,D,V,X,J,B"
CopyColumnsToAnotherWB ActiveWorkbook.ActiveSheet, Workbooks("columntest").Worksheets("test"), sourceCols, targetCols
End Sub
just change ActiveWorkbook.ActiveSheet and Workbooks("columntest").Worksheets("test") to your actual source and target workbooks and worksheets
I have 3 open Excel files which i have opened using this code;
Dim myWorkbooks As New Collection
Sub GetFile()
Dim fNameAndPath As Variant, i As Long, x As Variant
fNameAndPath = Application.GetOpenFilename("All Files (*.*), *.*", , "Select Files To Be Opened", , True)
If Not IsArray(fNameAndPath) Then
If fNameAndPath = False Then Exit Sub Else fNameAndPath = Array (fNameAndPath)
End If
For i = LBound(fNameAndPath) To UBound(fNameAndPath)
Set x = Workbooks.Open(fNameAndPath(i))
myWorkbooks.Add x
Next
End Sub
i merged all the Sheets i Need in one Workbook. There is a mastersheet called "KomKo" in this Workbook. And i have other Sheets which are "data (2)" , "data (3)" and "data(4)". These Sheets can be more then 4 so i might have Sheets called "data(11) " and so on. I would like to be able to copy Column C of all "data" Sheets and paste it to Column A of "KomKo" Sheet. i should be able to paste These values to the next empty value of that Column A.
How can i do this ?
So, after you have corrected your question, this code should do the desired work:
Dim masterSheet As Worksheet
Set masterSheet = Sheets("Komko")
'Variable to save the used Range of the master sheet
Dim usedRangeMaster As Integer
Dim ws As Worksheet
'loop through each worksheet in current workbook
For Each ws In Worksheets
'If sheetname contains "data" (UCase casts the Name to upper case letters)
If InStr(1, UCase(ws.Name), "DATA", vbTextCompare) > 0 Then
'calculate the used range of the master sheet
usedRangeMaster = masterSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
'Variable to save the used Range of the sub sheet
Dim usedRangeSub As Integer
'calculate the used range of the sub sheet
usedRangeSub = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
'copy relevant range from the subsheet
ws.Range("C1:C" & usedRangeSub).Copy
'paste the copied range after the used range in column a
masterSheet.Range("A" & usedRangeMaster).PasteSpecial
End If
Next ws
Since you already have a collection containing the relevant workbooks, you can just loop through these and copy the relevant stuff into your main wb.
So define a variable for the master sheet(to be able to refer to it)
And one Variable inside the loop which holds the "subsheet":
Dim mastersheet As Workbook
Set mastersheet = ThisWorkbook 'Assuming the code is inside the master sheet
Dim wb As Workbook
For Each wb In myWorkbooks
'Copy stuff
'Example to get a value from the "subsheet"
mastersheet.Sheets("sheet1").Cells(1, 1).Value = wb.Sheets("sheet1").Cells(1, 1)
Next wb
Then inside the loop, copy column c for example and paste it into column a of the master sheet:
wb.Sheets("sheet1").Range("C1").EntireColumn.Copy
mastersheet.Sheets("sheet1").Range("A1").PasteSpecial
I want to automatize a process which requires me looking up up to 20 workbooks and copying a cell if another cell is matching with the main workbook. I want to create something similar to Excel's built-in lookup function but is has to handle and loop through multiple workbooks. I've uploaded a screenshot which shows how the sheet ("Basis") in the main workbook looks like and an example of one of the sheets ("Report") that I copy the cell value from. The workbooks that contain the Report sheets (one sheet for every workbook) are stored in a folder locally.
So far I've tried to keep it simple by starting with one "Report Workbook" and then trying to copy the value over to the main workbook. This is how I want the logic to be: If there is a match between cell B10 (highlighted in red) in the reports sheet and one of the cells in range I4:I19 (highlighted in green), then the value in cell F13 should be copied in the Index column (highlighted in yellow), otherwise don't do anything. Loop and repeat procedure with every workbook in the folder.
In this particular case, there is a match for "200S", which means that the value 105 in cell F13 should be copied in cell L18. (Notice, that multiple routes can be in the same cell separated with a comma (just like here).
This is my code so far, and it works but I want it to loop through several workbooks in a fixed folder:
Sub CopyLookup()
Dim rng1 As Range, c1 As Range, rng2 As Range, c2 As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lnLastRow1 As Long, lnLastRow2 As Long
'Create an object for each worksheet:
Set ws1 = Worksheets("Report")
Set ws2 = Worksheets("Basis")
'Get the row number of the last cell containing data in the basis sheet:
lnLastRow2 = ws2.Cells(ws2.Cells.Rows.Count, "A").End(xlUp).Row
'Create range objects for the two columns to be compared:
Set rng1 = ws1.Range("B10")
Set rng2 = ws2.Range("I4:I19")
'Loop through each cell in col I in sheet 2:
For Each c2 In rng2
'Check if the cell is not blank:
If c2.Value <> "" Then
'Loop through each cell in cell B10 in other sheet:
For Each c1 In rng1
'Test if cells match:
If c1.Value = c2.Value Then
'Copy value from sheet 1 to sheet 2 (main workbook):
c2.Offset(0, 3).Value = c1.Offset(3, 4).Value
'Move on to next cell in sheet 2:
Exit For '(exits the "For Each c1 In rng1" loop)
End If
Next c1
End If
Next c2
End Sub
The code has to be modified to handle separate workbooks (and not one workbook as it is done at the moment) and loop through several workbooks in the folder and compare them to the main workbook where the values are copied over.
I'm just giving you an example how to loop through the report Files.
This Code should be in the Basis Workbook. It Loops Through the RootFolder and adds all Files matching the Report.xslx File Pattern in the File Variable. Modify this as needed.
Dim File As Variant
Dim fileList As Collection
Dim RootFolder As String
Set fileList = New Collection
'Path of Folder to search for Reportfiles
RootFolder = "C:\Example\Path\"
'Modify *Report*.xlsx to match your Report File Names
File = Dir(RootFolder & "*Report*.xlsx")
'Loop Through all Report files
While File <> ""
'Add File to Collection
fileList.Add RootFolder & File
File = Dir
Wend
Dim FilePath As Variant
Dim objBasis As Workbook
Dim objReport As Workbook
'Set BasisFile
Set objBasis = ThisWorkbook
'Loop Through Report Files
For Each FilePath In fileList
'Open Workbook
Set objReport = Workbooks.Open(FilePath)
'#######################################################
'PASTE YOUR CODE HERE
'Example To access Values from Sheet in ReportFile
Debug.Print objReport.Sheets("Report").Cells(1, 1).Value
'#######################################################
'Close ReportFile without saving
objReport.Close False
Next FilePath
I'm new to using VBA and have found the code below. It works fine but I need all the rows in the source file. How can I change the code so I'm not limited to using the row numbers as the will be differten every time.
Private Sub Import1_Click()
' Get customer workbook...
Dim customerBook As Workbook
Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetWorkbook As Workbook
' make weak assumption that active workbook is the target
Set targetWorkbook = Application.ActiveWorkbook
' get the customer workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select an input file "
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
' assume range is A1 - G10 in sheet1
' copy data from customer to target workbook
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets(1)
Dim sourceSheet As Worksheet
Set sourceSheet = customerWorkbook.Worksheets(1)
targetSheet.Range("A6", "G10").Value = sourceSheet.Range("A2", "G6").Value
' Close customer workbook
customerWorkbook.Close
End Sub
Assuming you want to copy the entire sheet onto a blank sheet in your current workbook and only keep values (your question doesn't specify that too well), you could replace this line:
targetSheet.Range("A6", "G10").Value = sourceSheet.Range("A2", "G6").Value
With this:
sourceSheet.UsedRange.Copy targetSheet.Range("A1")
sourceSheet.UsedRange.Value = sourceSheet.UsedRange.Value
Hope that proves to do the trick!
UPDATE
Baed upon your last comment, try replacing this line:
sourceSheet.UsedRange.Copy targetSheet.Range("A1")
With this line:
Intersect(sourceSheet.UsedRange, sourceSheet.UsedRange.Offset(1,0)).Copy targetSheet.Range("A1")
The final part Range("A1") can be updated to paste the results wherever you want them.
Hope this does the trick!!
Just the following line has to be changed like I've given below:
targetSheet.Range("A6", "G10").Value = sourceSheet.Range("A2", "G6").Value
First, using name ranges (top-left of excel where the name of the cell appears), name the start and end cell of the source sheet. Say, you call them "start" and "end".
Now, you can also name your start cell in targetsheet. End cell is not required because it will paste everything anyways. This is optional and you can stay without naming it like below.
The code will then look like...
targetSheet.Range("A6").Value = sourceSheet.Range("start", "end").Value
If you name the targetSheet start cell ("start_target" for example) as well then it will be like this :
targetSheet.Range("start_target").Value = sourceSheet.Range("start", "end").Value