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?
Related
I have 4 macros running one after the other:
1st - looks for the latest (newest) file in the source file location: In here I have a problem, because if there is no file at the location (C:\Source File) then, the file that is currently opened (main file) is formatted in the way that only the source file should be. I don't need message box and I don't want this (Main) file to be formatted if there is no source data file in the location.
'1
Option Explicit
Sub OpenLatestFile()
Application.ScreenUpdating = False
Dim MyPath As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date
MyPath = "C:\Source File\"
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
MyFile = Dir(MyPath & "*.csv", vbNormal)
If Len(MyFile) = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If
Do While Len(MyFile) > 0
LMD = FileDateTime(MyPath & MyFile)
If LMD > LatestDate Then
LatestFile = MyFile
LatestDate = LMD
End If
MyFile = Dir
Loop
Workbooks.Open MyPath & LatestFile
Application.ScreenUpdating = True
End Sub
2nd Macro: Column Removals
'2
Sub RemoveCols()
Application.ScreenUpdating = False
Alfa1 = ActiveWorkbook.Name
Range("X:AA,FA:I").Delete
Application.ScreenUpdating = True
End Sub
3rd: Row Removal
'3
Sub RemoveXYZ()
Application.ScreenUpdating = False
Dim lLRow As Long
With Sheets(1)
lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("C:C").AutoFilter Field:=1, Criteria1:="XYZ"
.Range("C2:C" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete xlShiftUp
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
4th: Copy formatted data from the source file into the Main file (which has Macros in it)
'4
Option Explicit
Sub TransferData()
Application.ScreenUpdating = False
Dim Last_Row1 As Long, Last_Row2 As Long
Dim WB1 As Workbook, WB2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Set WB1 = ActiveWorkbook
Set ws1 = WB1.Sheets(1)
Set WB2 = Workbooks("MainFile.xlsm")
Set ws2 = WB2.Sheets("Master")
Last_Row1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
Last_Row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
ws1.Range("A2:Z" & Last_Row1).Copy ws2.Range("A" & Last_Row2)
WB2.Save
Application.Quit
Application.DisplayAlerts = False
WB1.SaveChanges = False
WB2.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Can you please advise how to maximize the efficiency of the above codes and make sure that the main file is not being formatted if there's no data in the "source file folder"?
Moreover, the 1st macro is looking for the latest file (I would like to make sure that it doesn't pick up the file from the previous day) - any idea how to add a command "do not open source data if date is "minus 1 from today's date"?
Thanks
West
I combined all 4 macros and cleaned up a few pieces. The biggest change is setting your workbooks and worksheets earlier so the referencing was easier.
Is macro 2 affecting the source file or the master file? If each macro runs one after another, then it seems it would be the source file, which is what I did in the code below. If that is wrong you will need to move .Range("X:AA,FA:I").Delete out of the With WS1 block and change it to WS2.Range("X:AA,FA:I").Delete.
As you can see, the first part of the code is almost identical. When MyFile is first assigned, it will be a zero-length string if there are no .csv files in the directory. The code then tests whether MyFile is in fact a zero-length string: If Len(MyFile) > 0 Then. So if no .csv files exist in MyPath, the If statement is executed and runs Exit Sub, which stops execution of the procedure. Because the code is all in one sub, the formatting code will not run if the folder is empty.
So to make this work you will need to stop the calls on macros 2-4 and replace macro 1 with the code below.
Option Explicit
Sub ProcessLatestFile()
Dim MyPath As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date
Dim lLRow As Long
Dim Last_Row1 As Long, Last_Row2 As Long
Dim WB1 As Workbook, WB2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Application.ScreenUpdating = False
'Check for file
MyPath = "C:\Source File\"
MyFile = Dir(MyPath & "*.csv", vbNormal)
If Len(MyFile) = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If
Do While Len(MyFile) > 0
LMD = FileDateTime(MyPath & MyFile)
If LMD > LatestDate Then
LatestFile = MyFile
LatestDate = LMD
End If
MyFile = Dir
Loop
'Open Source File
Set WB1 = Workbooks.Open(MyPath & LatestFile)
Set ws1 = WB1.Sheets(1)
Set WB2 = Workbooks("MainFile.xlsm")
Set ws2 = WB2.Sheets("Master")
'Format Source File
With WS1
.Range("X:AA,FA:I").Delete
lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("C:C").AutoFilter Field:=1, Criteria1:="XYZ"
.Range("C1:C" & lLRow).Offset(1,0).SpecialCells(xlCellTypeVisible).EntireRow.Delete xlShiftUp
.AutoFilterMode = False
End With
'Copy data
Last_Row1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
Last_Row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
ws1.Range("A2:Z" & Last_Row1).Copy ws2.Range("A" & Last_Row2)
'Clean Up
Application.DisplayAlerts = False
WB1.SaveChanges = False
WB2.Save
Application.DisplayAlerts = True
Application.Quit
Application.ScreenUpdating = True
End Sub
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
I have the following VBA code meant to loop through a given folder and compile all files of a certain type into one single worksheet.
Sub cons_data()
Dim Master As Workbook
Dim sourceBook As Workbook
Dim sourceData As Worksheet
Dim CurrentFileName As String
Dim myPath As String
Dim LastRow As Long
Dim lRow As Long
Dim i As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'The folder containing the files to be recap'd
myPath = "path"
'Finds the name of the first file of type .xls in the current directory
CurrentFileName = Dir(myPath & "\*.txt*")
'Create a workbook for the recap report
Set Master = ThisWorkbook
For i = 1 To Master.Worksheets.Count
With Master.Worksheets(i)
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
If lRow > 1 Then .Rows("2:" & lRow).ClearContents
End With
Next i
Do
Workbooks.Open (myPath & "\" & CurrentFileName)
Set sourceBook = Workbooks(CurrentFileName)
For i = 1 To sourceBook.Worksheets.Count
Set sourceData = sourceBook.Worksheets(i)
With sourceData
LastRow = Master.Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Rows("2:" & lRow).Copy Master.Worksheets("Sheet1").Rows(LastRow + 1)
End With
Next i
sourceBook.Close
'Calling DIR w/o argument finds the next .txt file within the current directory.
CurrentFileName = Dir()
Loop While CurrentFileName <> ""
MsgBox "Done"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This script works fine on certain file types, but for some reason when running it on a list of text files with a standard format (some of which are duplicates) it stops and presents the most recent entry it was working on in a separate Excel sheet. Is there any obvious reason looking at the code that this might be happening?
You need to kill old processes and discharge resources memory by adding after :
Set sourceBook = nothing
After
sourceBook.close
Hope this can help
Objective - extracting data from multiple workbooks (5 in total); pasting the data into a new workbook.
Problem/Issue:
1) After running the below VBA code it's able to copy data from all the 5 workbooks but while pasting it's pasting data for only one of them.
2) Pop-up window for Clipboard is full. I've written a code to clear the clipboard but it doesn't seem to function as I still get the pop-up window.
VBA Code:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim MyPath As String
MyPath = "Directory path"
MyFile = Dir(MyPath)
Do While Len(MyFile) > 0
If MyFile = "filename.xlsb" Then
End If
Workbooks.Open (MyPath & MyFile)
Range("A3:CP10000").Copy
ActiveWorkbook.Close
'calculating the empty row
erow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
a = ActiveWorkbook.Name
b = ActiveSheet.Name
Worksheets("Raw Data").Paste Range("A2")
Application.CutCopyMode = False ' for clearing clipboard
MyFile = Dir
Loop
End Sub
I tried two other commands below as well, but they seem to just return no data at all.
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow + 1, 1), Cells(erow + 1, 30)) `pasting the data`
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range("A2")`pasting the data`
Update.
Here is the current code:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow As Long
Dim MyPath As String
Dim wb As Workbook
MyPath = "C:\Users\username\Downloads\PROJECTS\Project Name\Input file\"
MyFile = Dir(MyPath)
Do While Len(MyFile) > 0
If InStr(MyFile, "post_level.xlsb") > 0 Then
Set wb = Workbooks.Open(MyPath & MyFile)
Range("A3:CP10000").Copy
'calculating the empty row
erow = ThisWorkbook.Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Worksheets("Raw Data").Paste (ThisWorkbook.Worksheets("Raw Data").Range("A" & erow + 2))
Application.DisplayAlerts = False
wb.Close False
Application.DisplayAlerts = True
End If
MyFile = Dir
Loop
ActiveWindow.Zoom = 90
End Sub
Update2.
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow As Long
Dim MyPath As String
Dim wb As Workbook
MyPath = "C:\Users\username\Downloads\PROJECTS\ProjectNameFolder\SubFolder\MainFolder\Input file"
MyFile = Dir("C:\Users\username\Downloads\PROJECTS\ProjectNameFolder\SubFolder\MainFolder\Input file\*.*")
Do While Len(MyFile) > 0
If InStr(MyFile, ".csv") > 0 Then
Set wb = Workbooks.Open(MyPath & MyFile)
Range("A3:CP10000").Copy
'calculating the empty row
erow = ThisWorkbook.Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Worksheets("Raw Data").Paste (ThisWorkbook.Worksheets("Raw Data").Range("A" & erow + 2))
Application.DisplayAlerts = False
wb.Close False
Application.DisplayAlerts = True
End If
MyFile = Dir
Loop
End Sub
I hope I can help... There are multiple errors in your code, and I am not sure if I fixed them the way you'd want.
It would be useful to mention just one main mistake. You cannot have these 2 lines together:
If MyFile = "filename.xlsb" Then
End If
Between these lines you must put every procedure that you want to do IF he If condition is met. In the original case, if there was a file named "filename.xlsb", nothing would have happened, as you immediately closed the code block...
Try something similar to the following code. It worked for me to import data from all the files in the directory C:\Temp\ which have the extension of .xlsb
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow As Long
Dim MyPath As String
Dim wb As Workbook
MyPath = "C:\Temp\"
MyFile = Dir(MyPath)
Do While Len(MyFile) > 0
If InStr(MyFile, ".xlsb") > 0 Then
Set wb = Workbooks.Open(MyPath & MyFile)
Range("A3:CP10000").Copy
'calculating the empty row
erow = ThisWorkbook.Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Worksheets("Raw Data").Paste (ThisWorkbook.Worksheets("Raw Data").Range("A" & erow + 2))
Application.DisplayAlerts = False
wb.Close False
Application.DisplayAlerts = True
End If
MyFile = Dir
Loop
End Sub
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.