I am having an issue with my code. I want to:
Combine multiple .csv files into 1 workbook with each .csv file as a separate sheet;
Shorten the sheet names(since they are too long with extra metadata;
Add a new sheet with the sheet names as hyperlinks to the sheets;
save the file as xlsx.
My problem is that when I step through the code or run it via alt+F8 it works fine, but when I use the shortcut it doesn't do anything but open the first .csv file. The macro is in the personal.xlsb location.
I am sure I could simplify my code so any suggestions are very welcome. Here is my code:
Sub CombineCsvFilesWithShortSheetLinks()
'ctrl+Shift+b
'Will ask you to open CSV files you wish to combine
Dim myDir As String, fn As String, wb As Workbook
Set wb = ActiveWorkbook
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
Application.ScreenUpdating = False
If myDir = "" Then Exit Sub
fn = Dir(myDir & "*.csv")
Do While fn <> ""
With Workbooks.Open(myDir & fn)
.ActiveSheet.Copy after:=wb.Sheets(wb.Sheets.Count)
.Close False
End With
fn = Dir
Loop
'save as
Dim workbook_Name As Variant
workbook_Name = Application.GetSaveAsFilename
If workbook_Name <> False Then
ActiveWorkbook.SaveAs _
Filename:=workbook_Name ', _
'FileFormat:=52(-4143 xlWorkbookNormal =Excel workbook file format.) 'I had issues with this line because it would just same a extensionless file, so my work around was to just type .xlsx at the end of my file name
End If
'List WS Name Rename Add Hyperlink
'Will shorten the sheet names and add a new sheet with a list of hyperlinks to each sheet
'list old names
Dim xWs As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
xTitleId = "sheetnames"
Application.Sheets(xTitleId).Delete
Sheets("Sheet1").Select
Set xWs = Application.ActiveSheet
xWs.Name = xTitleId
For i = 2 To Application.Sheets.Count
xWs.Range("A" & (i - 1)) = Application.Sheets(i).Name
Next
Application.DisplayAlerts = True
'list new names'
selectworksheet = "sheetnames"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=MID(RC[-1],21,12)"
ActiveCell.Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A11")
ActiveCell.Range("A1:A11").Select
'rename'
selectworksheet = "sheetnames"
For i = 1 To 12
On Error Resume Next
oldname = Cells(i, 1).Value
newname = Cells(i, 2).Value
Sheets(oldname).Name = newname
Next
'create hyperlink page that Creates Links To All Sheets
Range("C1").Select
Dim cell As Range
For Each xWs In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> xWs.Name Then
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"'" & xWs.Name & "'" & "!A1", TextToDisplay:=xWs.Name
ActiveCell.Offset(1, 0).Select
End If
Next xWs
'save_workbook
ActiveWorkbook.Save
End Sub
Related
I am trying to copy only the values over from one workbook where calculations are done to another that holds all data. I have tried using .Value and xlPasteSpecial, but I think I'm using them incorrectly. I have limited VBA experience and am not a programmer.
Sub Consolidate()
Dim fName As String, fPath As String, fPathDone As String
Dim lr As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now
Set wsMaster = ThisWorkbook.Sheets("BM Condition") 'sheet report is built into
With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
.UsedRange.Offset(1).EntireRow.Clear
NR = 2
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If
'Path and filename (edit this section to suit)
fPath = "C:\Users\me\Desktop\Test" 'remember final \ in this string"
fPathDone = fPath & "Imported\" 'remember final \ in this string
On Error Resume Next
MkDir fPathDone 'creates the completed folder if missing
On Error GoTo 0
fName = Dir(fPath & "*.xls*") 'listing of desired files, edit filter as desired
'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file
'This is the section to customize, replace with your own action code as needed
lr = Range("A" & Rows.Count).End(xlUp).Row 'Find last row
Range("P14:S" & lr).EntireRow.Copy .Range("A" & NR).PasteSpecial xlPasteValues
wbData.Close False 'close file
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
' Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
End If
fName = Dir 'ready next filename
Loop
End With
ErrorExit: 'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub
I want only values from P14-S14. Can anyone assist with pulling only values from these cells?
I have a folder with nearly 1000 .csv files. Each of these files contains 2 columns, and I would like to copy only one of these columns and transpose it onto a new workbook. The new workbook will contain all the data from each of these files. The following code is what I have generated:
Sub AllFiles()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
folderPath = "J:etc. etc. etc." 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.csv")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
wb.Range(Range("B1"), Range("B1").End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
ActiveWorkbook.Close True
Windows("Compiled.xlsm").Activate
Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
For whatever reason the code does not work and a box pops-up saying "Code execution has been interrupted." Once I hit "Debug" the following line is highlighted:
wb.Range(Range("B1"), Range("B1").End(xlDown)).Select
I am not experienced with VBA at all and I am having trouble troubleshooting this issue. Any idea on what this means and what I can do?
The highlighted line is referring to a range on the workbook that is running the macro as opposed to the range within the workbook you have opened. Try replacing with this:
wb.Range(wb.Range("B1"), wb.Range("B1").End(xlDown)).Select
However I would suggest you avoid using the Select function altogether as it tends to slow down code. I've trimmed the loop a bit to avoid using Select and Activate:
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
wb.Range(wb.Cells(1,"B"), wb.Cells(Rows.Count,"B").End(xlUp)).Copy
Workbooks("Compiled.xlsm").Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
wb.Close True
Filename = Dir
Loop
Once you open file file, the active workbook is the book just opened and the active sheet is also established.
Your code fails primarily because of the wb.. (In general you would use a sheet reference instead), but in this case, replace:
wb.Range(Range("B1"), Range("B1").End(xlDown)).Select
with:
Range("B1").End(xlDown)).Select
(You also do not need Select to accomplish a copy/paste)
try with below
Sub AllFiles()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
folderPath = "c:\work\test\" 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
Range("B1:B" & Range("B" & Rows.count).End(xlUp).Row).Copy
Workbooks("Compiled").Worksheets("Sheet1").Range("A" & Range("A" & Rows.count).End(xlUp).Row + 1).PasteSpecial Transpose:=True
Workbooks(Filename).Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
wb.Range(...) will never work since wb is a Workbook object. You need a Worksheet object. Try:
Dim ws As Worksheet
Set ws = wb.Activesheet
ws.Range(ws.Range("B1"), ws.Range("B1").End(xlDown)).Select
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 written a macro for my boss to open a particular folder which contain approximately 100 workbooks having same format and collate all the data from those workbooks into the host excel where the macro is. Now the problem is, it works absolutely fine on my PC but when I had run it on the boss' PC it runs without executing the code(no data is collated) and displays the success message in the end in a second. Any help is appreciated. Here is the macro code
Sub collate()
Application.ScreenUpdating = False
Dim folderDialog As FileDialog
Dim folderPath As String, filename As String
Dim temp As Variant
Dim folder As Object, file As Object
Dim row As Integer, lastrow As Integer
MsgBox "Please select the folder containing all the input files", vbOKOnly
Set folderDialog = Application.FileDialog(msoFileDialogFolderPicker)
folderDialog.AllowMultiSelect = False
folderDialog.Show
On Error GoTo ext
folderPath = folderDialog.SelectedItems(1)
Set temp = CreateObject("Scripting.FileSystemObject")
Set folder = temp.GetFolder(folderPath)
row = Sheet1.Cells(Rows.Count, 2).End(xlUp).row
If row > 3 Then Sheet1.Range("B4:I" & row).Clear
row = 4
For Each file In folder.Files
filename = file.Name
filename = Left(filename, Len(filename) - 5)
Application.Workbooks.Open (folderPath & "\" & filename)
lastrow = Workbooks(filename).Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).row
Workbooks(filename).Worksheets("Sheet1").Range("B4:I" & lastrow).Copy
Sheet1.Range("B" & row).PasteSpecial xlPasteValues
Sheet1.Range("B" & row).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
row = Sheet1.Cells(Rows.Count, 2).End(xlUp).row + 1
Application.Workbooks(filename).Close savechanges:=False
Next
ext:
If folderPath = "" Then
MsgBox "Folder not selected!"
Application.ScreenUpdating = True
Exit Sub
End If
Sheet1.Range("A1").Select
Application.ScreenUpdating = True
MsgBox "Data successfully merged!", vbInformation
End Sub
You may need to enable the Microsoft Scripting Runtime library on your boss's computer if you haven't already. In some instances this library needs to be enabled in order to interface with the File System Object.
This library can be accessed from the Visual Basic Editor by pressing Tools > References > Microsoft Scripting Runtime. See the link below for further information.
Microsoft Scripting Runtime Library
Try this version
Sub LoopThroughFolder()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\Test2\"
MyFile = Dir(MyDir & "*.xlsx") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Sheet1")
MsgBox "your code goes here -" & MyFile
' Rws = .Cells(Rows.Count, "B").End(xlUp).Row
' Set Rng = Range(.Cells(2, 1), .Cells(Rws, 2))
' Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
ActiveWorkbook.Close True
End With
Application.DisplayAlerts = 1
MyFile = Dir()
Loop
End Sub
1 scenario where the code finishes in a second is when you have selected an empty folder or selecting a folder containing other than excel files.
Try checking the correct folder to select and execute the code. It should work fine.
I have a workbook (in Excel 2003 format) with data flowing continuously in three sheets. I want to create a macro in a new workbook (Excel 2010) in which all those data in all the three sheets in the previous workbook to get pasted in a single sheet of my new workbook, one after another. I would prefer the macro to open a dialog box to browse the file where the data is actually present. Can anyone help me please?
While searching I found something like given below. But that is not the one I want exactly.
Sub Open_Workbook()
Dim myFile As String
myFile = Application.GetOpenFilename _
(Title:="Please choose a file to open", _
FileFilter:="Excel Files .xls (.xls),")
If myFile = False Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Workbooks.Open Filename:=myFile
End If
End Sub
I suppose this code will help you
Sub wb_sheets_combine_into_one()
Dim sFileName$, UserName$, oWbname$, oWbname2$, sDSheet$ 'String type
Dim nCountDestination&, nCount&, nCountCol& 'Long type
Dim oSheet As Excel.Worksheet
Dim oRange As Range
Dim oFldialog As FileDialog
Set oFldialog = Application.FileDialog(msoFileDialogFilePicker)
With oFldialog
If .Show = -1 Then
.Title = "Select File"
.AllowMultiSelect = False
sFileName = .SelectedItems(1)
Else
Exit Sub
End If
End With
'open source workbook
Workbooks.Open sFileName: oWbname = ActiveWorkbook.Name
UserName = Environ("username")
Workbooks.Add: ActiveWorkbook.SaveAs Filename:= _
"C:\Users\" & UserName & _
"\Desktop\Consolidated.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
oWbname2 = ActiveWorkbook.Name
sDSheet = ActiveSheet.Name
nCountDestination = 1
Workbooks(oWbname).Activate
For Each oSheet In Workbooks(oWbname).Worksheets
oSheet.Activate
sDSheet = ActiveSheet.Name
ActiveSheet.UsedRange.Copy
For Each oRange In ActiveSheet.UsedRange
nCountCol = oRange.Column
Next
Workbooks(oWbname2).Activate
Cells(nCountDestination, 1).PasteSpecial xlPasteAll
nCount = nCountDestination
For Each oRange In ActiveSheet.UsedRange
nCountDestination = oRange.Row + 1
Next
Range(Cells(nCount, nCountCol + 1), _
Cells(nCountDestination - 1, nCountCol + 1)).Value = oSheet.Name
Workbooks(oWbname).Activate
With ActiveWorkbook.Sheets(sDSheet).Tab
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0
End With
Next
Workbooks(oWbname2).Save: Workbooks(oWbname).Close False
MsgBox "File with consolidated data from workbook " & Chr(10) & _
"[ " & oWbname & " ] saved on your desktop!"
End Sub