Extremely slow moving of data VBA - Alternatives - excel

I have this working code which copies data in specific columns to a new file.
Sub GetFileCopyData()
Dim Fname As String
Dim SrcWbk As Workbook
Dim DestWbk As Workbook
Set DestWbk = ThisWorkbook
Application.Calculation = xlManual
Application.ScreenUpdating = False
Sheets("Data").UsedRange.ClearContents
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.csv*), *.csv*", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set SrcWbk = Workbooks.Open(Fname)
SrcWbk.Sheets(1).Range("A:A").Copy DestWbk.Sheets("Data").Range("A:A")
SrcWbk.Sheets(1).Range("E:E").Copy DestWbk.Sheets("Data").Range("B:B")
SrcWbk.Sheets(1).Range("M:M").Copy DestWbk.Sheets("Data").Range("C:C")
SrcWbk.Sheets(1).Range("AD:AD").Copy DestWbk.Sheets("Data").Range("D:D")
SrcWbk.Sheets(1).Range("AF:AF").Copy DestWbk.Sheets("Data").Range("E:E")
SrcWbk.Sheets(1).Range("DA:DA").Copy DestWbk.Sheets("Data").Range("F:F")
SrcWbk.Sheets(1).Range("AEG:AEG").Copy DestWbk.Sheets("Data").Range("G:G")
SrcWbk.Sheets(1).Range("AEM:AEM").Copy DestWbk.Sheets("Data").Range("H:H")
SrcWbk.Close False
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
This runs extremely slowly. I've already tried turning screen updating off etc. I read that the following is quicker than copying, which is slow.
Range("A1:Z100").value = Range("A101:Z200").value
Can anyone please tell me how to implement this? I tried using this code but it ended up being blank:
SrcWbk.Sheets(1).Range("A:A").Value = DestWbk.Sheets("Data").Range("A:A").Value

If all you're copying is values, rather than copying the entire column, which is very resource intensive (effectively you're copying 1048576 cells) you could try implementing a lastrow statement and only copy the used range of the column. This could drastically reduce your runtime depending on how many values you have. Something amongst the lines of:
Sub copy()
Dim lastr As Long
lastr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
Sheet2.Range("A1:A" & lastr).Value = Sheet1.Range("A1:A" & lastr).Value
End Sub
To adapt your code you should replace the following line:
SrcWbk.Sheets(1).Range("A:A").Copy DestWbk.Sheets("Data").Range("A:A")
With this:
lastr = SrcWbk.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
DestWbk.Sheets("Data").Range("A" & lastr).value = SrcWbk.Sheets(1).Range("A" & lastr).value
Please note if your column lengths vary, you should redo the lastr calculation for every column. If all your columns are the same length (All ending on the same row), then using the first calculation for every column will do.

It looks like your requirement is just extracting specific columns from CSV file, then Get & Transform should be the best fit rather than VBA solution.
Yet another option is to use Microsoft Text Driver via ADO in VBA.

Related

Find column headers by name and select all data below headers from multiple workbooks and paste the data one below other in master file in excel VBA

I have 5 different workbooks in a particular folder, Each workbook contains only 1 sheet in it.
Each workbook has same format and has about 145 headers on row 12.
This headers has some data below it, please note the data in each workbooks are different and has missing data too so not sure about last row data.
In Master file, i have mentioned 30 headers in row 3 which are needed.
I need a VBA macro which should look for headers from master file and copy the data from 1st file and paste it in master. Once the data is copied from 1st file it should copy the data from 2nd, 3rd, 4th and 5th file and paste one below another in master file.
Thanks
Please, test the next code:
Sub CopyInMaster()
Dim wb As Workbook, mWb As Workbook, mWbPath As String, shMWb As Worksheet, ws As Worksheet
Dim folderPath As String, fileName As String, arrHead, lastERM As Long, lastrWS As Long, arrCopy, i As Long, j As Long
folderPath = ThisWorkbook.path & "\TestImport\" 'use here the folder path where the workbooks to import data exist
'please, take care of the ending"\"
mWbPath = folderPath & "Master.xlsx" 'use here your Master workbook full name
'check if the master workbook is open. If not, open it
For Each wb In Workbooks
If wb.fullName = mWbPath Then Set mWb = wb: Exit For
Next
If mWb Is Nothing Then
Set mWb = Workbooks.Open(mWbPath)
End If
Set shMWb = mWb.Sheets(1) 'if the sheet to be updated in Master wb is not the first one, please adapt the code using its name
'put master headers in an array:
arrHead = shMWb.Range("A1", shMWb.cells(1, shMWb.Columns.count).End(xlToLeft)).value
'iterate between all workbooks to be used in the necessary folder:
fileName = Dir(folderPath & "*.xls*")
Do While fileName <> ""
If Not fileName = mWb.Name Then 'if the master workbook is not in the same folder, this lines can be eliminated (If - End If)
Set wb = Workbooks.Open(folderPath & fileName)
Set ws = wb.Sheets(1)
'copy each mathing column data:
For i = 1 To UBound(arrHead, 2)
For j = 1 To ws.cells(12, ws.Columns.count).End(xlToLeft).Column
If arrHead(1, i) = ws.cells(12, j).value Then
lastrWS = ws.cells(ws.rows.count, j).End(xlUp).row 'last row
lastERM = shMWb.cells(shMWb.rows.count, i).End(xlUp).row + 1 'first empty row
arrCopy = ws.Range(ws.cells(13, j), ws.cells(lastrWS, j)).value 'put the range to be copied in an array (to be faster)
shMWb.cells(lastERM, i).Resize(UBound(arrCopy), UBound(arrCopy, 2)).value = arrCopy 'drop the array content
End If
Next
Next i
wb.Close False 'close the workbook without saving it
End If
fileName = Dir()
Loop
End Sub
Please, take care to correctly adapt the necessary paths and 'Master' workbook full name!
It is good to learn, besides the above code, that we here do not offer free coding services. We (usually) only help people understanding their coding problems and learn. So, you should show us what you tried by your own and better explain what is to be done. Please, understand that I made an exception!
It is also good to know that when placing a question it is at least polite to frequently check it and answer the clarification questions, if any.
After testing it, I would like to receive some feedback. I asked about clarifications and I only assumed that this is what you like doing. If not, please accurately describe what you need against what the code returns.

Using Excel VBA to retrieve data from multiple MS Project Files

I have ran into an automation issue that I cannot seem to figure out.
Currently, I have a worksheet,("Project") that contains data in columns "A"(Project Name) & "B"(Project File Location).
Column "B" contains the string location of each MS Project file.
My VBA macro loops through column "B" and opens each MS Project file and copies a task with the .SelectTaskField method and then copies it back into column "E" of the worksheet.
The first 2 projects loop through without any issues, however, on the 3rd project, I receive the Run-time error '1004': An unexpected error occurred with the method.
I co-worker and I have poured through the code and the MS Project Files to see if there are any differences in the data and we cannot find any differences.
Below is a copy of the code that I have been using.
Just wanted to see if anyone else has had similar issues. I have found that MS Project does not like to be manipulated like Excel or Word.
Any help would be greatly appreciated.
Sub Test()
Dim ws As Worksheet
Set ws = Worksheets("Projects")
Dim lrow As Long
lrow = Range("B" & Rows.Count).End(xlUp).Row
'Turns off updates and alerts
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Select Daily Field Reports and clear worksheet
ws.Range("E2:E" & lrow).ClearContents
'Opens MS Project
Set objproject = CreateObject("MSProject.Project")
'This keeps MS Project invisible. If you want to see it, change to "True"
objproject.Application.Visible = True
Dim oproject As Range
'This cycles through the range and gathers the data for each project
For Each oproject In Range("B2:B" & lrow)
Set objproject = CreateObject("MSProject.Project")
oproject.Select
objproject.Application.FileOpen Selection
objproject.Application.Visible = True
objproject.Application.SelectTaskField Row:=1, Column:="Percent Complete", RowRelative:=False 'The column name must match. This is the only issue that I have uncovered.
objproject.Application.EditCopy
ws.Select
Dim lastrow As Long
lastrow = ws.Cells(Rows.Count, "E").End(xlUp).Row + 1
Dim Rng As Range
Set Rng = ws.Range("E" & lastrow)
'Rng.PasteSpecial xlPasteFormats
Rng.PasteSpecial xlPasteValues
objproject.Application.Quit
Next oproject
'Turns updates and alerts back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Closes MS Project
objproject.Application.Quit
End Sub
Using the SelectTaskField method presumes the file was saved in a task view and that the column you want is in the table of the view. Better to get the values you need directly from the Task object.
It appears you are looking for the % Complete value from the first task. In that case use this:
objproject.ActiveProject.Tasks(1).PercentComplete
Here's how it could work in your code. I took the liberty of simplifying it a bit:
Sub Test()
Dim ws As Worksheet
Set ws = Worksheets("Projects")
Dim lrow As Long
lrow = Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ws.Range("E2:E" & lrow).ClearContents
Dim objproject As MSProject.Application
Set objproject = CreateObject("MSProject.Application")
objproject.Application.Visible = True
Dim oproject As Range
For Each oproject In Range("B2:B" & lrow)
objproject.FileOpen Name:=oproject.Value, ReadOnly:=True
oproject.Offset(, 3) = objproject.ActiveProject.Tasks(1).PercentComplete
objproject.FileCloseEx
Next oproject
Application.ScreenUpdating = True
Application.DisplayAlerts = True
objproject.Quit
End Sub
Note that it is more straight-forward to get a reference to the application object rather than a child of that object: CreateObject("MSProject.Application") is preferable to CreateObject("MSProject.Project").

Copy non adjacent data cells into one workbook

this is the code that i am currently using right now, but its not enough to meet my objectives and i am stuck on how to continue....
So this code will copy the specified data from many other excel workbook in the form of xlsx into a main excel workbook and before that it will scan through the folder which contains all the different data files and the main file(all files supposed to be transfered here in a table form) e.g. Test3.xlsx,Test4.xlsx,Test.xlxs and Main.xlsm in the folder of ScanFiles. so everytime a new files comes into the folder, it will automatically update the main workbook by opening the data workbooks then copy the required data and paste it on the main workbook upon clicking a button.
Sub ScanFiles()
Dim myFile As String, path As String
Dim erow As Long, col As Long
path = "c:\Scanfiles\"
myFile = Dir(path & "*.xlsx")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
Set copyrange = Sheets("sheet1").Range("A18,B18,C18,D18,A19,B19,C19,D19")
Windows("master-wbk.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
cel.Copy
Cells(erow, col).PasteSpecial xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Objectives: 1st:orignal type of file is in "file" not xlsx, so hope to find a way to open the file in xlsx format automatically before start of copying data.
2nd: requires 3 types of specified data e.g. name,surname(both of them are in fixed position always in A18 to D18 and A19 to D19 , 3rd one is to find the date, however the date is almost always in different positions in the data sheet, so i hope to add on a part to the code that makes it search for something like "ended 20190808" it will always start with ended but will always be in diff rows or even columns. i also need to arrange the data according to the date from newest(top) to oldest(bottom) and state the month of the date in words instead of numbers e.g. june
Deeply Appreciate any form of help but if possible the small section of code that can add on to my coding will make it a lot easier because im tasked to do this in a very limited amount of time
Thank you!!!
Here's some code that does similar things to what you describe. The animated .gif shows it working by stepping through the code. First the 2 data (.xlsx) files are shown so you have an idea of their content. Each is located in the same folder as the main workbook and has data in column A. Then as we step through the code each file is opened, its data manipulated (row 3 is deleted) and transferred into adjacent columns of the main workbook. The code is not limited to .xlsx files and will work with text files as well, as long as ext is defined.
Hopefully, once you understand how this works you can modify it to apply it to your case.
Option Explicit
Sub CombineFiles()
Dim theDir As String, numFiles As Integer
Dim sh As Worksheet, wk As Workbook, newSheet As Worksheet
Dim newColumn As Range, r As Range, s As String
Const ext = ".xlsx"
Err.Clear
theDir = ThisWorkbook.Path
Set newSheet = ThisWorkbook.Sheets.Add
newSheet.Name = "Combined"
Set newColumn = newSheet.Range("A1")
'Loop through all files in directory
s = Dir(theDir & "\*" & ext)
While s <> ""
numFiles = numFiles + 1
On Error Resume Next
Set wk = Workbooks.Open(theDir & "\" & s)
Set sh = ActiveSheet
sh.Rows(3).Delete Shift:=xlUp
Set r = Range("A1")
Range(r, r.End(xlDown)).Copy
newSheet.Activate
newColumn.Offset(0, numFiles) = wk.Name
newColumn.Offset(1, numFiles).Select
newSheet.Paste
Application.DisplayAlerts = False
wk.Close False
Application.DisplayAlerts = True
s = Dir()
Wend
MsgBox (numFiles & " files were processed.")
End Sub
For copy/paste of pictures see examples on this or this page. To find the last cell containing data in a column see this page; note that one example involves using the .find command. More generally, to learn how to use .find in vba, use the macro recorder and then adjust the resulting code.

Copy columns to new workbook and save as csv

I'm trying to:
Copy data (columns A and B) from one workbook (data.xlsx).
Paste into a new workbook (as values).
Save as CSV with a filename taken from column A in a third workbook (URLs.xlsx).
Process to repeat, taking the same data (which is randomised every time it is pasted) from data.xlsx and pasted into a new CSV - there are 200 rows in URLs.xlsx and so we should end up with 200 files.
I've read lots of topics, here are two I found:
Excel VBA Copy a Range into a New Workbook
https://www.excelcampus.com/vba/copy-paste-another-workbook/
What I've tried
Copying code and replacing the relevant components from various different articles across the web. Some of them work, but when I add the missing bits, I run into errors I don't understand.
Well here is an example avoiding copy pasting in new workbooks:
Expected input like:
Data.xlsx range A1:B200 with RANDBETWEEN() function:
URLs.xlsx range A1:A200 with some URL like so:
Run this code (will take approximately 1 second on my machine, tested with timer):
Dim wbData As Workbook, WBurls As Workbook
Dim CSVFileDir As String, CSVVal As String
Dim A As Long, X As Long, Y As Long, Z As Long
Option Explicit
Sub Transfer2CSV()
Set wbData = Workbooks("data.xlsx") 'Make sure it is open upon running macro
Set WBurls = Workbooks("URLs.xlsx") 'Make sure it is open upon running macro
For X = 1 To 200 'Looping through the 200 rows of WBurls
CSVFileDir = "C:\YourDrive\" & WBurls.Sheets(1).Cells(X, 1).Value & ".csv"
CSVVal = ""
A = FreeFile
Open CSVFileDir For Output As #A
With wbData.Sheets(1).Range("A1:B200") ' or whichever range you using here
.Calculate 'Randomize your range again
For Y = 1 To 200 'or however many rows you have in column A and B.
For Z = 1 To 2
CSVVal = CSVVal & .Cells(Y, Z).Value & ","
Next Z
Print #A, Left(CSVVal, Len(CSVVal) - 2)
CSVVal = ""
Next Y
End With
Close #A
Next X
End Sub
Output:
With each file looking like:
This should work. Make sure your data and URLS workbooks are open.
Sub Macro1()
Dim wsData As Worksheet, wsUrl As Worksheet, wbNew as Workbook
Dim CSVDir as String, rngU As Range
Set wsData = Workbooks("data.xlsx").Worksheets(1)
Set wsUrl = Workbooks("URLs.xlsx").Worksheets(1)
Set rngU = wsUrl.Range("A1", wsUrl.Range("A" & wsUrl.Rows.Count).End(xlUp))
CSVDir = "C:\Users\thomas.mcerlean\Desktop\Work\" 'you gave this as your dir
Set wbNew = Workbooks.Add
For Each cell In rngU
wsData.Range("A1", wsData.Range("B" & wsData.Rows.Count).End(xlUp)).Copy Destination:= wbNew.Worksheets(1).Range("A1")
wbNew.SaveAs Filename:= CSVDir & cell.Value & ".csv", FileFormat:=xlCSV
Next cell
wbNew.Close SaveChanges:=False
End Sub

Copying base data sheet along with selected sheets from source workbook to new workbook

I am looking at building a master workbook which receives a monthly dump of data for all Cost Centres which will then populate a large number of worksheets within the workbook, and which then need to be split off and sent out to service heads. A service head will receive a selection of worksheets based on the first 4 characters of the sheet name (although this may change in due course).
eg 1234x, 1234y, 5678a, 5678b will produce two new workbooks named 1234 and 5678 with two sheets in each.
I have cobbled some code from various forum to create a macro that will work through a hard coded array defining the service head 4 character codes and create a series of new workbooks. And which seems to work.
However.. I also need to include the main data dump sheet within the source file (called "data") with the the array of files being copied over so that the links remain with the data sheet being copied over. If I write a line to copy over the data sheet separately, the new workbook still refers back to the source file, which service heads do not have access to.
So main question is: how can I add the "data" tab into the Sheets(CopyNames).Copy code so it is copied over with all the other files in the array at the same to keep the links intact?
Second question is if I decide it is the first two characters of the worksheet define the sheets that relate to a service head, how do I tweak the split/mid line of code - I've trialled around but am getting tied up in knots!
Any other tips to make the code more elegant much appreciated (there may be quite a long list of service head codes and I am sure there is a better way of creating a list for the routine to loop through)
Sub Copy_Sheets()
Dim strNames As String, strWSName As String
Dim arrNames, CopyNames
Dim wbAct As Workbook
Dim i As Long
Dim arrlist As Object
Set arrlist = CreateObject("system.collections.arraylist")
arrlist.Add "1234"
arrlist.Add "5678"
Set wbAct = ActiveWorkbook
For Each Item In arrlist
For i = 1 To Sheets.Count
strNames = strNames & "," & Sheets(i).Name
Next i
arrNames = Split(Mid(strNames, 2), ",")
'strWSName =("1234")
strWSName = Item
Application.ScreenUpdating = False
CopyNames = Filter(arrNames, strWSName, True, vbTextCompare)
If UBound(CopyNames) > -1 Then
Sheets(CopyNames).Copy
ActiveWorkbook.SaveAs Filename:=strWSName & " " & Format(Now, "dd-mmm-yy h-mm-ss")
ActiveWorkbook.Close
wbAct.Activate
Else
MsgBox "No sheets found: " & strWSName
End If
Next Item
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub CopySheets()
With ThisWorkbook
Dim SheetIndex As Long
Dim ValidSheetNames() As String
ReDim ValidSheetNames(1 To .Worksheets.Count)
' Build a 1 dimensional array called ValidSheetNames, which contains every sheet in the master workbook other than DEDICATEDSHEET. '
Dim ws As Worksheet
For Each ws In .Worksheets
If ws.Name <> "DEDICATEDSHEET" Then
SheetIndex = SheetIndex + 1
ValidSheetNames(SheetIndex) = ws.Name
End If
Next ws
ReDim Preserve ValidSheetNames(1 To SheetIndex)
' Read all ServiceCodes into a 1-dimensional array '
Dim ServiceHeadCodes As Variant
ServiceHeadCodes = Application.Transpose(.Worksheets("DEDICATEDSHEET").Range("CCLIST[CC]").Value2)
Dim CodeIndex As Long
' Now loop through each ServiceHeadCode '
For CodeIndex = LBound(ServiceHeadCodes) To UBound(ServiceHeadCodes)
' Put all sheet names which contain the current ServiceHeadCode into an array called SheetsToCopy '
Dim SheetsToCopy() As String
SheetsToCopy = Filter(ValidSheetNames, ServiceHeadCodes(CodeIndex), True, vbTextCompare)
' Check if SheetToCopy now contains any sheet names at all. '
If UBound(SheetsToCopy) > -1 Then
' Add the name of the Data sheet to the end of the array '
ReDim Preserve SheetsToCopy(LBound(SheetsToCopy) To (UBound(SheetsToCopy) + 1))
SheetsToCopy(UBound(SheetsToCopy)) = "Data"
Dim OutputWorkbook As Workbook
Set OutputWorkbook = Application.Workbooks.Add
' Copy all sheets which are in SheetToCopy array to newly created OutputWorkbook '
.Worksheets(SheetsToCopy).Copy OutputWorkbook.Worksheets(1)
' Delete the default Sheet1, which should be at the end as copied sheets were inserted before it. '
' But suppress the Are you sure you want to delete this sheet.. message. '
Application.DisplayAlerts = False
OutputWorkbook.Worksheets(OutputWorkbook.Worksheets.Count).Delete
Application.DisplayAlerts = True
' Re-enable alerts, as we want to see any other dialogue boxes/messages
' Not providing a full directory path below means OutputWorkbook will be saved wherever Thisworkbook is saved.'
OutputWorkbook.SaveAs Filename:=ServiceHeadCodes(CodeIndex) & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx", FileFormat:=51
OutputWorkbook.Close
Else
MsgBox "No sheets found: " & ServiceHeadCodes(CodeIndex)
End If
Next CodeIndex
End With
End Sub
Untested and written on mobile, sorry for bad formatting.
This approach proposes that you store all service head codes in a 1-column Excel table on a dedicated sheet that is referred to via Excel table nomenclature (which might be easier than ArrayList.Add for each new service head code).
I assume code is stored in master workbook ('thisworkbook'), which might not be true.
You could modify the serviceheadcodes table directly on the spreadsheet itself, if you later decide that SheetsToCopy will be determined by first 2, 3 or X characters -- or you could modify array itself with left$() function.
Hope it works or gives you some ideas.
Edit: This is my sheet and table layout (which I assume matches yours).
And this is what the code above gives me on my computer.

Resources