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.
Related
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.
I need to save an active range of texts to a .txt file.
The range is a column F within the worksheet called "Reports". The number of rows depends on how many rows the report generates. This column F contains email addresses, which we need to upload to another system via a .txt file.
In the .txt file, each address will be located in a different line without other delimiters.
I have code, but it leaves the first line of the text file blank, starting with the second line.
Sub Macro_Newsletter()
Dim c As Range
Dim r As Range
Dim output As String
For Each r In Worksheets("Reports").Range("F2:F10000").Rows
For Each c In r.Cells
output = output & vbNewLine & c.Value
Next c
Next r
Open "C:\Users\joseph.lin\Desktop\Database\Newsletter" For Output As #1
Print #1, output
Close
End Sub
I only know how to output them to outlook. Please help me figure out how to do this using VBA.
This will do the trick:
Sub Macro_Newsletter()
Dim wbText As Workbook
Dim wsReports As Worksheet
Set wbText = Workbooks.Add
Set wsReports = ThisWorkbook.Worksheets("Reports")
With wsReports
Dim lRow As Long
lRow = .Range("F" & .Rows.Count).End(xlUp).Row 'get last row of emails
.Range("F2:F" & lRow).Copy wbText.Sheets(1).Range("A1")
End With
'turn off alerts so you don't see messages about compatibility and such
Application.DisplayAlerts = False
With wbText
.SaveAs Filename:="C:\Users\joseph.lin\Desktop\Database\Newsletter\Emails.txt", _
FileFormat:=xlText
.Close False
End With
Application.DisplayAlerts = True
End Sub
You can simply record a macro (Developer Tab) and save it as a csv or .txt file - once you have this you can edit it as necessary. If you can save it to Outlook you should be able to save it to a text document.
This is a fairly common procedure and should be well documented within various resources.
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
I want to copy specific range from excel files stored in a specific folder and paste it in another excel file.I am able to do so.However,every time i run the code it starts with the very first file in the folder.I want to copy data from only the files that haven't been updated before.Is there a way to do that?
EG:
"file1.xlsx" and "file2.xlsx" are in a folder. I want to copy data from the given files and paste it in "NewFile.xlsm" (I'm able to achieve this) However, if I add "file3.xlsx" and "file4.xlsx" in the folder and then run the macro, it copies data from "file1.xlsx" and "file2.xlsx" as well.I want it to copy data only from "file3.xlsx" and "file4.xlsx" this time as the data from previous 2 files is already saved.
(The code i have is given below)
Path = "C:\Users\National\Desktop\TEST Codes\PO\Excel\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
If Filename = "Z master for PO.xlsm" Then
Exit Sub
End If
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Sheets("DETAILED").Range("A3:S15").Copy
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveWorkbook.Close
Dim LASTROW As Long, WS As Worksheet, LS As Long
Set WS = Sheets("sheet1")
LASTROW = WS.Range("R" & Rows.Count).End(xlUp).Row + 1
WS.Range("A" & LASTROW).Select
ActiveSheet.Paste Destination:=WS.Range("A" & LASTROW)
Application.CutCopyMode = False
Filename = Dir()
Loop
Range("A7").Select
One way of doing this is by looking at the DateLastAccessed property, or the DateLastModified property. These are both properties of the File object, see this MS documentation.
You can set a minimum date/time, which should exclude the files you don't want processed.
Be sure to set the correct reference
Option Explicit
Sub GoThroughFiles()
Dim Path As String, Filename As String,
Dim fso, fileinfo
Set fso = CreateObject("Scripting.FileSystemObject")
Path = "C:\Users\National\Desktop\TEST Codes\PO\Excel\"
Filename = Dir(Path & "*.xls")
Set fileinfo = fso.GetFile(Path & Filename)
Do While Len(Filename) > 0
If fileinfo.DateLastAccessed > DateAdd("n", -5, Now) 'If the file was last accessed less than 5 minutes ago
'Do stuff with the file
End If
FileName = Dir()
Loop
End Sub
Furthermore, avoid using Select and Activate as using both will make your code prone to errors. Here is a thread on how to avoid it. Next to that, I added Option Explicit which makes sure you avoid other errors caused by, for example, spelling mistakes.
I need to save an active range of texts to a .txt file.
The range is a column F within the worksheet called "Reports". The number of rows depends on how many rows the report generates. This column F contains email addresses, which we need to upload to another system via a .txt file.
In the .txt file, each address will be located in a different line without other delimiters.
I have code, but it leaves the first line of the text file blank, starting with the second line.
Sub Macro_Newsletter()
Dim c As Range
Dim r As Range
Dim output As String
For Each r In Worksheets("Reports").Range("F2:F10000").Rows
For Each c In r.Cells
output = output & vbNewLine & c.Value
Next c
Next r
Open "C:\Users\joseph.lin\Desktop\Database\Newsletter" For Output As #1
Print #1, output
Close
End Sub
I only know how to output them to outlook. Please help me figure out how to do this using VBA.
This will do the trick:
Sub Macro_Newsletter()
Dim wbText As Workbook
Dim wsReports As Worksheet
Set wbText = Workbooks.Add
Set wsReports = ThisWorkbook.Worksheets("Reports")
With wsReports
Dim lRow As Long
lRow = .Range("F" & .Rows.Count).End(xlUp).Row 'get last row of emails
.Range("F2:F" & lRow).Copy wbText.Sheets(1).Range("A1")
End With
'turn off alerts so you don't see messages about compatibility and such
Application.DisplayAlerts = False
With wbText
.SaveAs Filename:="C:\Users\joseph.lin\Desktop\Database\Newsletter\Emails.txt", _
FileFormat:=xlText
.Close False
End With
Application.DisplayAlerts = True
End Sub
You can simply record a macro (Developer Tab) and save it as a csv or .txt file - once you have this you can edit it as necessary. If you can save it to Outlook you should be able to save it to a text document.
This is a fairly common procedure and should be well documented within various resources.