I need help creating a piece of code that will.
Identify two separate workbooks: workbook1 (the source file) & workbook2 (active.workbook).
take the column title in workbook1, find that column title in workbook 2 and copy the content of the column from workbook1 into workbook 2.
move to the next column in workbook1 until its title is blank.
This code works for me. Note the comments.
Sub copyA2B()
Dim wb As Workbook
Dim wbSrc As String
Dim cel As Range
'assuming you don't know the source workbook name, looping through the workbooks, otherwise no loop needed
For Each wb In Workbooks
If wb.Name <> ActiveWorkbook.Name Then
wbSrc = wb.Name
Exit For
End If
Next
With Workbooks(wbSrc).ActiveSheet
'assuming the column order is different between the two files, looping through the titles, otherwise no loop needed
For Each cel In .Rows(1).Cells 'assuming the titles are in the first row in both workbooks
If cel <> "" And cel(2) <> "" Then
.Range(cel(2), cel(1).End(xlDown)).Copy Rows(1).Find(cel.Value)(2)
End If
Next
End With
End Sub
Related
So i have a workbook with around 500 worksheets, and i need to change the value of a cell, say A1, in each worksheet, to a value in a range from another workbook.
For example,
the value of A1 in Sheet1 in Workbook1 = A1 in Sheet1 of Workbook2
the value of A1 in Sheet2 in Workbook1 = A2 in Sheet1 of Workbook2
the value of A1 in Sheet3 in Workbook1 = A3 in Sheet1 of Workbook2
etc.
I've been trying to alter and use the following, but getting nowhere, any help would be appreciated.
Thanks
Sub mycode()
For Each Worksheet InThisWorkbook.Sheets
Range(“A1″) = “Exceltip”
Next
End Sub
Try this:
Open your destination workbook and store a reference to the workbook in a variable
Loop through the worksheets in your current workbook using a For loop
Fully qualify your references, using this new variable name and ThisWorkbook to distingish between ranges on different workbooks.
Sub TransferValues()
Dim workbook2 As Workbook
Dim i As Long
Set workbook2 = Workbooks.Open("C://My Documents/.../SomeWorkbook2.xlsx")
For i = 1 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(i).Range("A1").Value = workbook2.Worksheets("Sheet1").Range("A1").Offset(i - 1, 0).Value
Next i
workbook2.Close SaveChanges:=False
End Sub
here's a variation on CallumDA code, mainly to optimize memory accesses and, hence, performance (should it ever be an issue):
Sub TransferValues()
Dim myValues As Variant
With Workbooks.Open("C://My Documents//SomeWorkbook2.xlsx") 'open and reference "source " workbook
myValues = Application.Transpose(.Worksheets("Sheet1").Range("A1").Resize(ThisWorkbook.Worksheets.Count).Value) 'store referenced workbook "Sheet1" worksheet values in column A from row 1 down to "workbook1" (i.e. the one where the macro resides in) sheets number
.Close False 'close referenced workbook
End With
Dim sht As Worksheet
For Each sht In ThisWorkbook.Worksheets
sht.Range("A1").Value = myValues(sht.Index)
Next
End Sub
I got some script here to open up multiple workbooks with a worksheet and then copy it to a worksheet as a loop, but I need an additional cell (the date) from another worksheet in the multiple workbooks because the output I got cannot be changed and just added to the same sheet.
What I need is for this code to include a single cell range from another sheet on the workbook and then fill it to the bottom of the range per workbook.
I cant use UNION as it's not the same length, and I looked up merging ranges into one, but I get type mismatch errors.
VBA: How to combine two ranges on different sheets into one, to loop through I tried this but I can't figure out how to put it into my code.
Here is the code I have that works so far for just the one range. The rngdate copies over but does not leave a gap or autofill to the next loop, it just pastes under each other, so maybe this code will work but I'm missing something basic like autofill?
Dim vFileNames As Variant
Dim y As Long
Dim wbTemp As Workbook
Dim wbNew As Workbook
Dim blHeader As Boolean
Dim Rng As Range
Dim rngDate As Range
Application.ScreenUpdating = False
Set wbNew = Workbooks("master_timesheet") '.Add
blHeader = False
vFileNames = Application.GetOpenFilename(Title:="Select all workbooks to copy", _
MultiSelect:=True)
'Will not be array if no file is selected
'If user selects one or more files, files will be stored as an array
If Not IsArray(vFileNames) Then GoTo ConsolidateWB_End
For y = LBound(vFileNames) To UBound(vFileNames)
'Open each wb selected
Set wbTemp = Workbooks.Open(vFileNames(y))
Set rngDate = wbTemp.Worksheets("Communications Unlimited Inc").Range("A5").CurrentRegion
Set Rng = wbTemp.Worksheets("Export").Range("A1").CurrentRegion
'If header row already copied, then offset by 1 to exclude header
If blHeader Then
Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1)
'If header row not already copied, keep rng as is and change blHeader to true
Else
blHeader = True
End If
'Paste to next row on new wb
Rng.Copy Destination:=wbNew.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
rngDate.Copy Destination:=wbNew.Sheets(1).Range("P65536").End(xlUp).Offset(1, 0)
wbTemp.Close SaveChanges:=False
Next y
ConsolidateWB_End:
Application.ScreenUpdating = True
End Sub
If I read your problem correctly you want the date, rngdate, pasted adjacent to each and every line of data you have just copied. However your current code only puts the data on the first row. Below is an adaptation of how I have solved this problem myself, taking account of your existing code. (My guess is that there is a much more elegant solution than this which I'm just not aware.)
Dim pasterangefirstrow As Integer
...
pasterangefirstrow = wbNew.Sheets(1).Range("D65536").End(xlUp).Offset(1, 0).Row
...
With wbNewSheets(1)
Rng.Copy Destination:=.Range("D65536").End(xlUp).Offset(1, 0)
rngdate.Copy Destination:=.Range("P" & pasterangefirstrow & ":P" & pasterangefirstrow + Rng.Rows.Count - 1)
End With
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 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