I have a work sheet named Final_Sheet, I want to create a button on that sheet and execute the following operation
Select Cell Range A1:D30 and pickup the values from cell only and create a new Excel file and paste the copied cell values into Sheet1 of created excel file. I am able to o this much, further I can't understand what to do can anybody please help me out?
Private Sub Button1_Click()
Dim rownum As Integer
Dim selection As Range
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
rownum = InputBox("Row No to Copy :", "OK")
selection = ActiveSheet.Range(Cells(1, 1), Cells(rownum, 10)).Select
selection.Copy
Flname = InputBox("Enter File Name :", "Creating New File...")
MsgBox ("Output File Created Successfully")
If Flname <> "" Then
Set NewWkbk = Workbooks.Add
ThisWorkbook.Sheets(1).Range("D1:D30").Copy Before:=NewWkbk.Sheets(1)
NewWkbk.Sheet(1).Select
Cells(1, 1).Activate
selection.PasteSpecial xlPasteValues
NewWkbk.SaveAs ThisWorkbook.Path & "\" & Flname
ActiveWorkbook.Close
End If
End Sub
The code below should do as you've asked.
EDIT: Pastes values only
Private Sub Button1_Click()
'Dim Variables
Dim ws As Worksheet
Dim rng As Range
Dim wbNew As Workbook, wbCurrent As Workbook
Dim strFileName As String
'Assign object variables
Set wbCurrent = ActiveWorkbook
Set ws = wbCurrent.ActiveSheet
Set rng = ws.Range("A1:D30") 'Amend range if needed
'Get desired file path from user
strFileName = InputBox("Enter File Name: ", "Creating New File...")
If strFileName <> "" Then
'Create new Workbook and paste rng into it
Set wbNew = Workbooks.Add
rng.Copy
wbNew.Sheets(1).Range("A1:D30").PasteSpecial xlValues
'Save new workbook using desired filepath
wbNew.SaveAs wbCurrent.Path & "\" & strFileName
End If
End Sub
It wasn't clear to me from the question which workbook you wished to close with ActiveWorkbook.Close but you could easily add wbNew.Close or wbCurrent.Close below wbNew.SaveAs ... as required.
Related
Since I am new to VBA I created a code which can open a .csv file and copy data from .csv to an excel file without opening both.
Actually it works for excel files but When I use a .csv file it displays me an error message "SUBSCRIPT OUT OF RANGE".How do I solve this? Thank You!
Sub Copywb1()
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Setwkb1 = ThisWorkbook
Setwkb2 = Workbooks.Open("C:\Desktop\AAA.xlsx")
Setwkb1 = Workbooks.Open("C\Reports\BBB.csv")
Setsht1 = wkb1.Sheets("Reports")
Setsht2 = wkb2.Sheets("Fees")
sht1.Range("A1:BM9").Copy
sht2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
wkb2.Close True
wkb1.Close True
End Sub
Here's a working example I had that you should able to to adapt to your needs fairly easily:
Sub demo_loadDataFromCSV()
Const csvFile = "x:\mypath\myfile.csv"
Dim ws As Worksheet, csv As Workbook, cCount As Long, cName As String
' Application.ScreenUpdating = False 'keep these commented-out until...
' Application.DisplayAlerts = False ' ...done testing/troubleshooting!
Set ws = ThisWorkbook.ActiveSheet 'remember where we parked
Workbooks.Open csvFile 'open the csv
Set csv = ActiveWorkbook 'create object of csv workbook
cName = csv.Name 'get name of csv while its open
ActiveSheet.Columns("A:B").Copy 'copy columns A and B
ws.Activate 'go back to the first sheet
ws.Range("A1").PasteSpecial xlPasteValues 'paste values
cCount = Selection.Cells.Count 'count pasted cells
csv.Close 'close CSV
Application.DisplayAlerts = True 're-enable alerts
Application.ScreenUpdating = True 'resume screen updates
MsgBox cCount & " cells were copied from " & cName _
& " to " & ws.Parent.Name, vbInformation, "Done"
End Sub
More Information:
MS Docs : Workbooks.Open Method (Excel)
MS Docs : Range.PasteSpecial Method (Excel) (Excel)
CFO : Referring to Other Worksheets or Workbooks in Excel VBA
Code VBA : Set Workbook variable
Here are the minor changes in code, now it will select the new workbook and paste the data in the selected sheet.
Sub demo_loadDataFromCSV()
Const csvFile = "C:\Users\PC\Downloads\R1C2.txt"
Dim ws As Worksheet, csv As Workbook, cCount As Long, cName As String
Dim ws2 As Worksheet
' Application.ScreenUpdating = False 'keep these commented-out until...
' Application.DisplayAlerts = False ' ...done testing/troubleshooting!
Set ws = ThisWorkbook.ActiveSheet 'remember where we parked
Workbooks.Open csvFile 'open the csv
Set csv = ActiveWorkbook 'create object of csv workbook
'to open new workbook
Filename = Application.GetOpenFilename(, , "Browse for workbook")
cName = csv.Name 'get name of csv while its open
ActiveSheet.Columns("A:B").Copy 'copy columns A and B
'Open workbook
Workbooks.Open Filename
'Go to sheets Fees
Set test = ActiveWorkbook.Sheets("Fees")
test.Activate
test.Range("A1").PasteSpecial xlPasteValues 'paste values
cCount = Selection.Cells.Count 'count pasted cells
csv.Close 'close CSV
Application.DisplayAlerts = True 're-enable alerts
Application.ScreenUpdating = True 'resume screen updates
MsgBox cCount & " cells were copied from " & cName _
& " to " & ws.Parent.Name, vbInformation, "Done"
End Sub
I've been trying to come up with a way to split a workbook into separate workbooks based on identified worksheets in the workbook.
For example:
Say I had a worksheet for every letter in the alphabet.
I would want to split worksheets A through C into a new workbook named "A through C."
D through I will go into a new workbook named "D through I."
etc...
My idea would be to first insert a worksheet that in column A names the new workbook it will become and Columns b through as many columns as there are will the names of the worksheets to be copied into the new workbook.
Does anyone have an idea of how to make a macro for this? I've tried myself but have been unsuccessful.
Thank you!
I found this Macro out there. Does anyone think it can be modified to work?
Sub Test()
Dim Sh As Worksheet
Dim Rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Dim WB As Workbook
Application.ScreenUpdating = False
Set Sh = Worksheets("Sheet1")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
On Error Resume Next
For Each c In Rng
List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Rng = Sh.Range("A1:H" & Sh.Range("A65536").End(xlUp).Row)
For Each Item In List
Set WB = Workbooks.Add
Rng.AutoFilter Field:=1, Criteria1:=Item
Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A1")
Rng.AutoFilter
With WB
.SaveAs ThisWorkbook.Path & "\" & Item & ".xls"
.Close
End With
Next Item
Sh.Activate
Application.ScreenUpdating = True
End Sub
The following code assumes you have your control sheet (named "Split Parameters") in the workbook containing the macro, and it is set out with the desired filenames in column A, and the sheets that you wish to copy into that file (from the ActiveWorkbook, which might, or might not, be the one containing the macro) listed in columns B, C, etc. Row 1 is assumed to be headings, and is therefore ignored.
Sub SplitBook()
Dim lastRow As Long
Dim LastColumn As Long
Dim srcWB As Workbook
Dim newWB As Workbook
Dim i As Long
Dim c As Long
Dim XPath As String
Dim newName As String
Dim sheetName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set srcWB = ActiveWorkbook
XPath = srcWB.Path
With ThisWorkbook.Worksheets("Split Parameters")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow
'Take the first worksheet and create a new workbook
sheetName = .Cells(i, "B").Value
srcWB.Sheets(sheetName).Copy
Set newWB = ActiveWorkbook
'Now process all the other sheets that need to go into this workbook
LastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
For c = 3 To LastColumn
sheetName = .Cells(i, c).Value
srcWB.Sheets(sheetname).Copy After:=newWB.Sheets(newWb.Sheets.Count)
Next
'Save the new workbook
newName = .Cells(i, "A").Value
newWB.SaveAs Filename:=xPath & "\" & newName & ".xls", FileFormat:=xlExcel8
newWB.Close False
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I wrote the following code to clean the workbook and then to create empty sheets
Sub conclusion()
Dim xWs As Worksheet
Dim Path As String, Filename As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Sheet1" And xWs.Name <> "Summary" Then
xWs.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' create new sheets
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Summary").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
' copy the workbooks into the sheets (My question )
End Sub
and then it should read the path from a cell in my case B2 and look for all xls files in this folder and copy to the crated sheets whose names are in
I wrote the following
Path= Sheets("Summary").Range("B2").Value ***( it does not read the value of B2, why? )***
Filename = Dir("Path" & "*.xls")
Do While Filename <> ""
***here is my question, how can I write the following:
COPY THE WORKBOOK 1 INTO SHEET with the name from Cell A2***
Loop
To fix the first problem try:
With Application.Workbooks("BookName").Sheets("Summary")
Path = .Range("B1").Text & "\" & .Range("A2").Text
End With
For the second your variable Path is in quotes which it shouldn't be as it is not a string but a string variable. Not too sure why you had the wildcard asterisk in there either...
Filename = Dir(Path & ".xls")
For the last part, your For Loop is missing what it is that you want to cycle through (ie. cells)
For Each MyCell In MyRange.Cells
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
I'm using a VBA code to cycle through excel files in a directory and pull information from one worksheet and paste into a newly created worksheet. I'm also naming my new worksheets (in my destination file) by the name in one of the cells in the source file.
My code works for the first loop but fails/stops in the second loop (VBA points to an error in the Dest.Sheets.Add(After:=Dest.Sheets(Dest.Sheets.Count)).Name = Sheetname line. I need to loop through 75 of these files and I'm unsure of what's going on because it works correctly for the first file.
Thanks so much for the help!
Sub AddSummaryTables()
Dim Spath, Filename, Sheetname As String
Dim Source, Dest As Workbook
Dim WS As Worksheet
Set Dest = ThisWorkbook
Spath = InputBox("Enter File Source Path") & "\"
Filename = Dir(Spath & "*.xls*")
Do While Filename <> ""
Set Source = Workbooks.Open(Spath & Filename)
Sheetname = Source.Sheets("Summary").Range("B2").Text
MsgBox Sheetname
Dest.Sheets.Add(After:=Dest.Sheets(Dest.Sheets.Count)).Name = Sheetname
Source.Sheets("Summary").Range("A1:R150").Copy
Dest.Worksheets(Sheetname).Range("A1").PasteSpecial xlPasteValues
Dest.Worksheets(Sheetname).Range("A1").PasteSpecial xlPasteFormats
Dest.Worksheets(Sheetname).Range("A1:R150").WrapText = False
Dest.Worksheets(Sheetname).Rows.AutoFit
Dest.Worksheets(Sheetname).Columns.AutoFit
Source.Close SaveChanges:=False
Dest.Save
Filename = Dir()
Loop
End Sub
following Comintern's and Wyatt's suggestion you could try like follows
Option Explicit
Sub AddSummaryTables()
Dim sPath As String, fileName As String
Dim sourceWb As Workbook, destWb As Workbook
Dim sourceWs As Worksheet, destWs As Worksheet
Set destWb = ThisWorkbook
sPath = InputBox("Enter File Source Path") & "\"
fileName = Dir(sPath & "*.xls*")
Do While fileName <> ""
Set sourceWb = Workbooks.Open(sPath & fileName)
Set sourceWs = GetWorksheet(sourceWb, "Summary")
If Not sourceWs Is Nothing Then
Set destWs = SetWorksheet(destWb, sourceWs.Range("B2").Text)
sourceWs.Range("A1:R150").Copy
With destWs
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
.UsedRange.WrapText = False
.Rows.AutoFit
.Columns.AutoFit
End With
sourceWb.Close SaveChanges:=False
destWb.Save
End If
fileName = Dir()
Loop
End Sub
Function GetWorksheet(wb As Workbook, sheetName As String) As Worksheet
On Error Resume Next
Set GetWorksheet = wb.Worksheets(sheetName)
On Error GoTo 0
End Function
Function SetWorksheet(wb As Workbook, sheetName As String) As Worksheet
Dim i As Integer
Do While Not GetWorksheet(wb, sheetName & IIf(i = 0, "", "-" & i)) Is Nothing
i = i + 1
Loop
With wb
.Worksheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = sheetName & IIf(i = 0, "", "-" & Format(i, "000"))
Set SetWorksheet = .ActiveSheet
End With
End Function
where you make sure that
any opened workbook has a "Summary" worksheet
you name worksheets in your destination workbook such as not to have duplicates: if you happen to deal with say three worksheets named "Sheet5" then your destination workbook will have added worksheets "Sheet5", "Sheet5-001" and "Sheet5-002".
You're issue may be that when you are adding the sheet from the second workbook, it has the same name as the sheet from the first workbook. You could check if the sheet exists and add a number to it. The post below might help.
Test or check if sheet exists
I have a code see below to import data from different workbooks inside one folder. I try it and it works perfectly however I was wondering if someone could help me to improve it.
I explain: "zmaster.xlms" workbook is the one where all data are past in sheet one. In this same workbook in sheet2 i have a table like this:
Where the column "Excel Column code" is where the data should be past (in the "zmaster.xlms") and "Form Cell Code" correspond to the cells which should be copy from every workbooks (which are in the same file in my desktop).
Question: How To say to the macro to look at the table and copy the cell K26 and past it in the columnA of the zmaster file and loop until the end of the table?
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\Desktop\New folder\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
' Range("A1:D1").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
MyFile = Dir
Loop
End Sub
Thank you in advance for your help!
All you need to do is to loop through the cells in sheet 2 (zmaster.xlsm). Have a look at example code. Please, read comments.
[EDIT]
Code has been updated!
Option Explicit
'assuming that:
'- "Excel Column Code" is in column A
'- "Form Cell Code" is in column B
'in zmaster.xlsm!Sheet2
Sub UpdateData()
Dim sFile As String, sPath As String
Dim srcWbk As Workbook, dstWbk As Workbook
Dim srcWsh As Worksheet, dstWsh As Worksheet, infoWsh As Worksheet
Dim i As Long, j As Long, k As Long
On Error GoTo Err_UpdateData
Set dstWbk = ThisWorkbook
Set dstWsh = dstWbk.Worksheets("Sheet1")
Set infoWsh = dstWbk.Worksheets("Sheet2")
sPath = "C:\Desktop\New folder\"
sFile = Dir(sPath)
Do While Len(sFile) > 0
If sFile = "zmaster.xlsm" Then
GoTo SkipNext
End If
Set srcWbk = Workbooks.Open(sPath & sFile)
Set srcWsh = srcWbk.Worksheets(1)
i = 2
'loop through the information about copy-paste method
Do While infoWsh.Range("A" & i) <> ""
'get first empty row, use "Excel Column Code" to get column name
j = GetFirstEmpty(dstWsh, infoWsh.Range("A" & i))
'copy data from source sheet to the destination sheet
'use "Form Cell Code" to define destination cell
srcWsh.Range(infoWsh.Range("B" & i)).Copy dstWsh.Range(infoWsh.Range("A" & i) & j)
i = i + 1
Loop
srcwbk.Close SaveChanges:=False
SkipNext:
sFile = Dir
Loop
Exit_UpdateData:
On Error Resume Next
Set srcWsh = Nothing
Set dstWsh = Nothing
Set srcWbk = Nothing
Set dstWbk = Nothing
Exit Sub
Err_UpdateData:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_UpdateData
End Sub
'returns first empty row in a destination sheet based on column name
Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function
At the moment you code
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
is simply copying columns A to D of the first row of data in the source worksheet to a new row in the destination worksheet.
I'm assuming that you still want to create a new single row, but that you want the table on sheet2 to define which cells are put into which column of the new row.
you need to write something like this (which is untested):
Sub YourCode()
Dim MyFile As String
Dim erow
Dim Filepath As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsDestination As Worksheet
Dim rngMapping As Range
Dim DestinationRow As Long
Dim cell As Range
Filepath = "C:\Desktop\New folder\"
MyFile = Dir(Filepath)
Set wsDestination = ActiveWorkbook.Sheet1
' Named range "MappingTableFirstColumn" is defined as having the first column in the sheet2 table and all the rows of the table.
Set rngMapping = ActiveWorkbook.Names("MappingTable").RefersToRange
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Set wbSource = Workbooks.Open(Filepath & MyFile)
Set wsSource = wbSource.Sheets("Sheet1")
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For Each cell In rngMapping
wsDestination.Range(cell.Value & DestinationRow) = wsSource.Range(cell.Offset(0, 1)).Value
Next cell
MyFile = Dir
Loop
ActiveWorkbook.Close
End Sub