I am new in VBA. I have two sheets i.e. sheet1 has path of input Directory and Output directory.
On sheet2 i am started to code. i wants to read data from multiple xls files that are are stores in a folder . this folder path is specified in sheet1. i wants to copy all files headers from all xls files to sheet3 in a column.
my code is working well but i have given file path directly but i wants to get it from other sheet. Please help me. Below is my code and i have attched sheet1.
Public Sub CommandButton1_Click()
'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim mainwb As Workbook
Dim ws As Worksheet
Dim search_result As Range 'range search result
Dim blank_cell As Long
Dim wb As Workbook
Path = "D:\Testing\Data\Input\"
Filename = Dir(Path & "*.xls")
'--------------------------------------------
'OPEN EXCEL FILES
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Path & Filename)
'MySheet = Application.Caller.Worksheet.Name
'Set sh = MySheet()
'Variable = ActiveSheet.Name
' Sheets(Variable).Range("A1:D1").Copy
'Sheets("Sheet2").Column(B2).Select.Activate.Paste
' Sheets("Sheet2").Active
'Columns("B2").Select
Set wbk = ActiveWorkbook
Variable = ActiveSheet.Name
wbk.Sheets(Variable).Rows(1).EntireRow.Copy
Workbooks("Tool.xlsm").Activate
' Workbooks("DFT Tool.xlsm").Sheets("Sheet2").Activate
'ActiveWorkbook.ActiveSheet
'Sheets("Sheet2").Activate
'ActiveSheet.Columns("E").Select
' Range("E1").End(xlDown).Offset(1, 0).Select
'ActiveSheet.Paste
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet2")
For Each cell In ws.Columns(3).Cells
If IsEmpty(cell) = True Then cell.Select: Exit For
Next cell
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
' Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
wbk.Close savechanges:=False
Filename = Dir
Loop
End Sub
Thanks in Advance
Try
Path = Cells(2,2).value
This takes the Value of Cell B2 and stores it in the Path variable.
Another possibility:
Filename = Dir(Cells(2,2).value & "*.xls")
Related
I found this VBA code that works for combining workbooks in a folder, however, I need to modify it so that all worksheets in each workbook are copy/pasted and not just the first worksheet of each workbook. As of now, only the first worksheet in each selected workbook is being copied over. Where can I insert code to find data in all worksheets?
Thanks!
Sub MergeSelectedWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim SelectedFiles() As Variant
Dim NRow As Long
Dim FileName As String
Dim NFile As Long
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
' Modify this folder path to point to the files you want to use.
FolderPath = "S:\example"
' Set the current directory to the the folder path.
ChDrive FolderPath
ChDir FolderPath
' Open the file dialog box and filter on Excel files, allowing multiple files
' to be selected.
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1
' Loop through the list of returned file names
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
' Set FileName to be the current workbook file name to open.
FileName = SelectedFiles(NFile)
' Open the current workbook.
Set WorkBk = Workbooks.Open(FileName)
Dim LastRow As Long
LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
After:=WorkBk.Worksheets(1).Cells.Range("A1"), _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows).Row
Set SourceRange = WorkBk.Worksheets(1).Range("A1:Z" & LastRow)
' Set the destination range to start at column A and be the same size as the source range.
Set DestRange = SummarySheet.Range("A" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
Next NFile
' Call AutoFit on the destination sheet so that all data is readable.
SummarySheet.Columns.AutoFit
End Sub
Opens multiple workbooks (1 by 1), Copies data from all sheets onto one sheet. Make sure you modify the ranges that will work for you (copy range is currently A2 to Z(last row).
Option Explicit
Sub MoveSheets()
Dim IndvFiles As FileDialog
Dim Currentbook As Workbook
Dim x As Integer
Dim i As Integer
Dim CurrentSheets As Integer
Dim BookCount As Integer
'Opens File Dialog to Select Which Files You Want to Consolidate
Set IndvFiles = Application.FileDialog(msoFileDialogOpen)
With IndvFiles
.AllowMultiSelect = True
.Title = "Multi-select target data files:"
.ButtonName = ""
.Filters.Clear
.Show
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False
CurrentSheets = ThisWorkbook.Worksheets.Count
BookCount = IndvFiles.SelectedItems.Count
Dim LROW as Long
DIM LROW2 as Long
DIM Import as Range
For x = 1 To BookCount
On Error GoTo StopHere:
Set Currentbook = Workbooks.Open(IndvFiles.SelectedItems(X))
For i = 1 To Currentbook.Worksheets.Count
LROW = thisworkbook.sheets("desired sheet name paste").Range("A2").End(XLdown).Rows
LROW2=currentbook.sheets(i).Range("A2").End(XLdown).Rows
Set Import = currentbook.sheets(i).Range("A2:Z"&LROW2)
Import.Copy
ThisWorkbook.Sheets("Desired sheet name paste range").Range("A"&LROW).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
Next i
Currentbook.Close False
Next x
StopHere:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I'm currently using code that I found a few years ago to copy one worksheet to a new workbook, but it uses cells.copy which removes some important formatting. I'd like to use sheets.copy instead but the sheet names are constantly changing and I'm not sure how to code that. Thanks for your help. Here is the code I'm currently using:
Sub SheetsToFiles()
'Takes a sheet from a workbook and turns it into a file named after the
sheet name
Dim mySourceWB As Workbook
Dim mySourceSheet As Worksheet
Dim myDestWB As Workbook
Dim myNewFileName As String
' First capture current workbook and worksheet
Set mySourceWB = ActiveWorkbook
Set mySourceSheet = ActiveSheet
' Build new file name based
myNewFileName = mySourceWB.Path & "\" & mySourceSheet.Name & ".xlsx"
' Add new workbook and save with name of sheet from other file
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=myNewFileName
Set myDestWB = ActiveWorkbook
' Copy over sheet from previous file
mySourceWB.Activate
Cells.Copy
myDestWB.Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWindow.DisplayGridlines = False
' Resave new workbook
ActiveWorkbook.Save
' Close active workbook
ActiveWorkbook.Close
End Sub
I would use the Worksheet.copy method to copy the Worksheet to the new Workbook, this should preserve the formatting of the original sheet. Here's the code updated with comments:
Sub SheetsToFiles()
'Takes a sheet from a workbook and turns it into a file named after the Sheet Name
Dim mySourceWB As Workbook
Dim mySourceSheet As Worksheet
Dim myDestWB As Workbook
Dim myNewFileName As String
' First capture current workbook and worksheet
Set mySourceWB = ActiveWorkbook
Set mySourceSheet = ActiveSheet
' Build new file name based
myNewFileName = mySourceWB.Path & "\" & mySourceSheet.Name & ".xlsx"
' Create a new Workbook with one blank Worksheet (this will be deleted later)
Set myDestWB = Workbooks.Add(xlWBATWorksheet)
' Copy sheet to DestWB and paste after the first Worksheet
mySourceSheet.Copy After:=myDestWB.Worksheets(1)
' Delete the unused Worksheet, turn off alerts to bypass the confirmation box
Application.DisplayAlerts = False
myDestWB.Worksheets(1).Delete
Application.DisplayAlerts = True
' Save with name of sheet from other file
myDestWB.SaveAs Filename:=myNewFileName
' Close Destination workbook
myDestWB.Close
End Sub
Try this code ,
Sub SheetsToFiles()
'Takes a sheet from a workbook and turns it into a file named after the
Dim mySourceWB As Workbook
Dim mySourceSheet As Worksheet
Dim myDestWB As Workbook
Dim myNewFileName As String
' First capture current workbook and worksheet
Set mySourceWB = ActiveWorkbook
Set mySourceSheet = ActiveSheet
' Build new file name based
myNewFileName = mySourceWB.Path & "\" & mySourceSheet.Name & ".xlsx"
' Add new workbook and save with name of sheet from other file
Workbooks.Add
Set myDestWB = ActiveWorkbook
myDestWB.SaveAs Filename:=myNewFileName
' Copy over sheet from previous file
mySourceSheet.Range("A1:Z100").Copy Destination:=myDestWB.Sheets("Sheet1").Range("A1:Z100")
ActiveWindow.DisplayGridlines = False
' Resave new workbook
ActiveWorkbook.Save
' Close active workbook
ActiveWorkbook.Close
End Sub
This is exactly what I wanted but after changing the folder path file name etc. for my needs, it doesn't work.
My workbook's path is C:\Users\navinc\Desktop\
My file name is test(2)
My worksheet name is Master Project List
My target files in folder path C:\Users\navinc\Desktop\test\
Error message : "Subscript out of range" Is there anything i'm missing ?
My code :
Sub Macro1()
Dim file As String
Dim myPath As String
Dim wb As Workbook
Dim rng As Range
Dim wbMaster As Workbook
'if master workbook already opened
'Set wbMaster = Workbooks("test(2).xlsx")
'if master workbook is not opened
Set wbMaster = Workbooks.Open("C:\Users\navinc\Desktop\test(2).xlsx")
Set rng = wbMaster.Sheets("Master Project list").Range("A1:D1")
myPath = "C:\Users\navinc\Desktop\test\" ' note there is a back slash in the end
file = Dir(myPath & "*.xlsx*")
While (file <> "")
Set wb = Workbooks.Open(myPath & file)
rng.Copy
With wb.Worksheets("Master Project list").Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
End With
wb.Close SaveChanges:=True
Set wb = Nothing
file = Dir
Wend
Application.CutCopyMode = False
End Sub
Seems like wb doesn't have a sheet named "Master Project list" ?
If you don't know what the target sheet name will be then that's going to be tricky unless (eg) it's always the first worksheet you want, in which case you can use:
With wb.Worksheets(1).Range("A1")
I have a folder called "maildir". It contains folders named numerically. These folders contain text files.
I have hacked together a macro that opens the numerically named folder, opens its first text file, and copies the contents into Excel. It then opens the next file in the directory, and copies the new file into a new sheet in the same workbook.
Then, the procedure deletes all the rows below row five, for every sheet in the workbook.
The next step combines the content from all the sheets into a new sheet called "Combined".
Then, all sheets but "Combined" are deleted
The next step saves the workbook into a new folder called "enron_excel".
This is where I am stuck: I was able to get the macro to work fine until I added a "For Loop" which is designed to both open the numerically named folders, and save them with numerical names in the "enron_excel" folder.
But when I run the code, and look in the "enron_excel" folder, it seems that the "combined" step has been missed. Does anyone know what happened?
Thank you.
Sub all()
Application.DisplayAlerts = False
Dim J As Integer
Dim ws As Worksheet
Dim wks As Worksheet
For i = 1 To 3 ' What I want this for loop to do: open the file called "1" (and later 2 and 3), manipulate the data then save with the same number in a different file
Path = "C:\Users\Kate\Desktop\enron4\maildir\" ' open folder in a directory
Filename = Dir(Path & i & "*.txt") ' opens a folder, and a text file in that folder
Do While Filename <> "" ' opens file in folder and copies to sheet in excel workbook
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
For Each ws In ThisWorkbook.Worksheets ' deletes all the rows below row five
ws.Range("5:1000").Delete
Next ws
On Error Resume Next
Sheets(1).Select ' combines all the sheets into one worksheet
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next J
Sheets("Combined").Select ' selects the sheet calls "Combined" and deletes all the others
Application.DisplayAlerts = False
For Each wks In Worksheets
If wks.Name <> ActiveSheet.Name Then wks.Delete
Next wks
Path = "C:\Users\Kate\Desktop\enron_excel\" ' this opens a new path
FolderName = i
ActiveWorkbook.SaveAs Filename:=Path & FolderName ' this saves the file in the new path with the new name
Application.DisplayAlerts = True
Next i
End Sub
Why don't you use File System Object.
Something like:
Sub ReadAllfiles()
Dim fso As Scripting.FileSystemObject
Dim sFile As Scripting.File
Dim subFldr As Scripting.Folder
Dim wbName As String
Dim fldrPath As String
Dim fname As String
Dim fldrDesc As String
Dim wbTxt As Workbook
Dim ws As Worksheet
Dim wbDesc As Workbook
fldrDesc = "C:\User\Yourdestination\" '<~~ change to suit
fldrPath = "C:\User\Yourfolder" '<~~ change to suit
'iterate each folder of your source folder
Set fso = New Scripting.FileSystemObject
For Each subFldr In fso.GetFolder(fldrpath).SubFolders
wbName = subFldr.Name
Set wbDesc = Workbooks.Add 'add a new workbook
'create the combined sheet
Set ws = wbDesc.Sheets(1): ws.Name = "Combined"
'iterate each file on the folder
For Each sFile In subFldr.Files
fname = sFile.ParentFolder.Path & "\" & sFile.Name
Set wbTxt = Workbooks.Open(fname)
'I'm not sure why a text file will yield to multiple sheet
'so if that is really the case use your loop
'copy the 1st 4 rows to Combined sheet
wbTxt.Sheets(1).Range("1:4").Copy _
ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0)
wbTxt.Close False 'close source text file
Next
wbDesc.SaveAs fldrDesc & wbName 'save the workbook
wbDesc.Close True 'close
Next
End Sub
I just based it on how you describe what you want. Not tested though.
You will need to add reference to Microsoft Scripting Runtime. HTH.
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.