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
Related
I have searched for this issue already, but all the examples are way too complicated.
I just cannot use "Set workbook" and "Set worksheets" object. I will get error 1004: Object-defined error.
I would like to read path from the destination file sheet "Path": C:\Users\Holger\Documents\VBA\WB_data.xlsx
Please someone help.
Sub Get_numbers()
'I have got 2 sheets
Dim WB_dest As Workbook
Dim WB_data As Workbook
'I need 3 worksheets
Dim path_sheet As Worksheet
Dim dest_sheet As Worksheet
Dim data_sheet As Worksheet
'Data worksheet's path
Dim path As String
'Counter
Dim i As Byte
'I run this sub from destination file sheet "PATH" which is already open
Set WB_dest = ThisWorkbook
Set path_sheet = WB_dest.Worksheets("Path")
Set dest_sheet = WB_dest.Worksheets("TO")
'I set worksheet from the Excel taht I do not need to open, just reading
Set WB_data = Workbooks.Open(path)
Set data_sheet = WB_data.Worksheets("FROM")
'Data sheet contains three numbers in the first column
'and destination sheet also contains only three numbers in the first coulm
'I would like to add data_sheet numbers after dest_sheet numbers
For i = 4 To 6
dest_sheet.Cells(i, 1) = data_sheet(i, 1)
Next i
Try this...
Sub Get_numbers()
'I have got 2 sheets
Dim WB_dest As Workbook
Dim WB_data As Workbook
'I need 3 worksheets
Dim path_sheet As Worksheet
Dim dest_sheet As Worksheet
Dim data_sheet As Worksheet
'Data worksheet's path
Dim path As String
'Counter
Dim i As Byte
path = "C:\Users\Holger\Documents\VBA\WB_data.xlsx"
'I run this sub from destination file sheet "PATH" which is already open
Set WB_dest = ThisWorkbook
Set path_sheet = WB_dest.Worksheets("Path")
Set dest_sheet = WB_dest.Worksheets("TO")
'I set worksheet from the Excel taht I do not need to open, just reading
Set WB_data = Workbooks.Open(path)
Set data_sheet = WB_data.Worksheets("FROM")
'Data sheet contains three numbers in the first column
'and destination sheet also contains only three numbers in the first coulm
'I would like to add data_sheet numbers after dest_sheet numbers
data_sheet.Range("A4:A6").Copy
dest_sheet.Range("A4").PasteSpecial xlPasteValues
'For i = 4 To 6
' dest_sheet.Cells(i, 1) = data_sheet(i, 1)
'Next i
End Sub
I have a workbook with a master sheet for school report cards. I have a macro applied to a button for exporting information from the master sheet to separate, newly-generated sheets in the same workbook. A1:C71 is the template and goes to every new sheet, and the following columns of info, from D1:71 to Q1:71, each appear in separate sheets (always in D1:71).
Here's the screenshot (http://imgur.com/a/ZDOVb), and here's the code:
`Option Explicit
Sub parse_data()
Dim studsSht As Worksheet
Dim cell As Range
Dim stud As Variant
Set studsSht = Worksheets("Input")
With CreateObject("Scripting.Dictionary")
For Each cell In studsSht.Range("D7:Q7").SpecialCells(xlCellTypeConstants, xlTextValues)
.Item(cell.Value) = .Item(cell.Value) & cell.EntireColumn.Address(False, False) & ","
Next
For Each stud In .keys
Intersect(studsSht.UsedRange, studsSht.Range(Left(.Item(stud), Len(.Item(stud)) - 1))).Copy Destination:=GetSheet(CStr(stud)).Range("D1")
Next
End With
studsSht.Activate
End Sub
Function GetSheet(shtName As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(shtName)
If GetSheet Is Nothing Then
Set GetSheet = Sheets.Add(after:=Worksheets(Worksheets.Count))
GetSheet.Name = shtName
Sheets("Input").Range("A1:C71").Copy
GetSheet.Range("A1:D71").PasteSpecial xlAll
GetSheet.Range("A1:B71").EntireColumn.ColumnWidth = 17.57
GetSheet.Range("C1:C71").EntireColumn.ColumnWidth = 54.14
GetSheet.Range("D1:D71").EntireColumn.ColumnWidth = 22
End If
End Function`
I would now like to create a separate button to split the sheets into separate workbooks so that the master sheet can be kept for record keeping and the individual workbooks can be shared with parents online (without divulging the info of any kid to parents other than their own). I would like the workbooks to be saved with the existing name of the sheet, and wonder if there's a way to have the new workbooks automatically saved in the same folder as the original workbook without having to input a path name? (It does not share the same filename as any of the sheets).
I tried finding other code and modifying it, but I just get single blank workbooks and I need as many as have been generated (preferably full of data!), which varies depending on the class size. Here's the pathetic attempt:
`Sub split_Reports()
Dim splitPath As String
Dim w As Workbook
Dim ws As Worksheet
Dim i As Long, j As Long
Dim lastr As Long
Dim wbkName As String
Dim wksName As String
Set wsh = ThisWorkbook.Worksheets(1)
splitPath = "G:\splitWb\"
Set w = Workbooks.Add
For i = 1 To lastr
wbkName = ws
w.Worksheets.Add(After:=w.Worksheets(Worksheets.Count)).Name = ws
w.SaveAs splitPath
w.Close
Set w = Workbooks.Add
Next i
End Sub`
I have learned so much, and yet I know so little.
Maybe this will start you off, just some simple code to save each sheet as a new workbook. You would probably need some check that the sheet name is a valid file name.
Sub x()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
ws.Copy
ActiveWorkbook.Close SaveChanges:=True, Filename:=ws.Name & ".xlsx"
Next ws
End Sub
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 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
Trying to complete a VBA routine for the first time.
The goal is :
Use a vertical range of cell that have different names in each cell to create multiples worksheets in one new workbook.
Here's what i got until now :
Sub AddWorksheet()
Dim plage As Range
Dim i As Integer
Dim titre As String
Dim wb As Workbook
Set plage = Range("E6:E24")
Set wb = Workbooks.Add("New Workbook")
For i = 1 To plage.Height
If plage.Cells(i).Value <> "" Then
titre = plage.Cells(i).Value
ActiveWorkbook.Sheets("FeuilleTemplate").Copy After:=wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Activate
ActiveSheet.Name = titre
End If
Next i
End Sub
Until now the following line is giving me a hard time :
Set wb = Workbooks.add("New Worbook")
The error message is : Error execution '1004' :
The method 'dd' of the object 'Workbooks' has failed.
I'm having a hard time reading and finding the info too for how the methods and class works
I'm use to java.
Thanx for those who gona take time to help me thru this
I think we cannot add a workbook with a specified name as it is not yet saved. So just add workbook do all the operations and in the end save it with the desired name.
Sub AddWorksheet()
Application.DefaultSaveFormat = xlOpenXMLWorkbook
Dim plage As Range
Dim i As Integer
Dim OldBook As Workbook, NewBook As Workbook 'declare both workbooks
Set OldBook = ActiveWorkbook
spath = ThisWorkbook.Path
Set plage = OldBook.Sheets("Sheet Names").Range("E6:E24") 'Assuming that sheet names are in range E6:E24 in "Sheet Names" sheet in old workbook
Set NewBook = Workbooks.Add 'adding new workbook so as to copy the template sheet but this workbook is not saved yet
For i = 1 To plage.Height
If plage.Cells(i).Value <> "" Then 'for each non blank cell in range
OldBook.Sheets("FeuilleTemplate").Copy After:=NewBook.Sheets(NewBook.Sheets.Count) 'Copy "FeuilleTemplate" sheet in workbook after last sheet
NewBook.Sheets("FeuilleTemplate").Name = plage.Cells(i).Value 'Rename the sheet to the desired names from range E6:E24 in "Sheet Names" sheet in old workbook
End If
Next i
With NewBook
.SaveAs Filename:=spath & "\" & "New Workbook with Templates"
.Close SaveChanges:=True
End With
End Sub