Copy different workbooks from an folder into different sheets in one workbook - vba

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

Related

Splitting an identified range of spreadsheets to a new workbook with a new name

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

Excel VBA loop folder and check if Excel file name is equal to worksheet

I'm in need of some enlightment.
I'm trying to match a folder of Excel files with some sheets in an Excel workbook. So far, I'm able to read these Excel files names and corresponding sheets and copy to them to sheet1 B1 of my workbook. After that I create a sheet for every file.
I would like the macro to continue and compare every file in the directory with the sheets I have in my workbook. If the sheet name from workbook is equal to filename, than copy file contents (only sheet1 from these files has data).
This is what I have so far:
Sub readme()
Dim directory As String, fileName As String, sheet As Worksheet, i As Integer, j As Integer
Application.ScreenUpdating = False
directory = "D:\Claro Chile\Report_sem_formulas\"
fileName = Dir(directory & "*.xl??")
Do While fileName <> ""
i = i + 1
j = 2
Cells(i, 1) = fileName
Workbooks.Open (directory & fileName)
For Each sheet In Workbooks(fileName).Worksheets
Workbooks("Report Status v1.xlsm").Worksheets(1).Cells(i, j).Value = sheet.Name
j = j + 1
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Call create_sheets_starting_from_B1
End Sub
Sub create_sheets_starting_from_B1()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Summary").Range("B1")
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
Sheets("Summary").Move Before:=Sheets(1)
End Sub
untested!
but do you might need something like:
Sub sheetCompare()
Dim i As Integer
Dim mDirs As String
Dim path As String
Dim OutFile As Variant, SrcFile As Variant
Dim file As Variant
OutFile = ActiveWorkbook.Name
mDirs = "c:\" 'your dir here
file = Dir(mDirs)
While (file <> "")
path = mDirs + file
Workbooks.Open (path)
SrcFile = ActiveWorkbook.Name
For i = 1 To Workbooks(OutFile).Sheets.Count
If file = Workbooks(OutFile).Sheets(i).Name Then
'copy logic
End If
Next i
Workbooks(file).Close (False)
file = Dir
Wend
End Sub

Excel Macro: Replace formulas and save sheet as own file without changing original document

I have a workbook with a lot of worksheets. I only work on sheets marked with a !. I want to replace all formulas by values and store the sheets as own .xls files. My script is exactly doing that. My problem is that the original document is affected as well. Is there a way to replace the values only on the copied sheet which will be stored so the original document stays the same?
Dim wbk As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim cl As Object
Dim xPath As String
Dim isReadable As Boolean
Dim sName As String
xPath = Application.ActiveWorkbook.Path
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
On Error Resume Next
Set wbk = ActiveWorkbook
For Each ws In wbk.Sheets
isReadable = (InStr(ws.Name, "!")) > 0
If isReadable Then
Debug.Print ws.Name
Set rng = ws.Range("A1").SpecialCells(xlCellTypeFormulas, 23)
If Not (rng Is Nothing) Then
For Each cl In rng
cl.Value = cl.Value
Next cl
End If
sName = Replace(ws.Name, "!", "")
sName = LCase(Replace(sName, "+", ""))
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & sName & ".xlsx", CreateBackup:=False
Application.ActiveWorkbook.Close False
Debug.Print sName
End If
Next ws
Application.Calculate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Done, do not save the changes!"
Make a copy of the sheet and work on that:
Sub DoStuff()
Dim wsOrig As Worksheet
Dim wsNew As Worksheet
Dim wbOrig As Workbook
Dim wbNew As Workbook
Set wsOrig = ActiveSheet ' or whatever
Set wbOrig = ActiveWorkbook ' or whatever
For s = 1 To wbOrig.Sheets.Count
If wbOrig.Sheets(s) ' meets my conditions then....
Application.SetWarnings False ' don't question if we want to delete thinsg
Set wbNew = Workbooks.Add
wsOrig.Copy After:=wbNew.Sheets(1)
wbNew.Sheets(1).Delete ' delete the default Sheet1 of the new workbook
Set wsNew = wbNew.Sheets(1)
With wsNew
' do all the stuff I want to do
End With
wbNew.SaveAs ' whatever
Application.SetWarnings True
End If
Next s
End Sub
Here is another way to make the changes only on the copied sheet:
Dim ws As Worksheet, ws2 As Worksheet
For Each ws In Worksheets
If ws.Name Like "*!*" Then
ws.Copy
Set ws2 = Workbooks(Workbooks.Count).Sheets(1) ' newest workbook
ws2.Name = LCase(Replace(Replace(ws.Name, "!", ""), "+", ""))
ws2.UsedRange.Value = ws2.UsedRange.Value
ws2.Parent.SaveAs ws.Parent.Path & "\" & sName & ".xlsx", CreateBackup:=False ' add checks if the file already exist and if path contains illegal characters that are not allowed
ws2.Parent.Close False
End If
Next

Excel Sheet Name Error

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

Copy value from active sheet to new excel file

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.