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.
Related
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.
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 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.
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 have plain text titles in one .csv and hyperlinks for those titles in another .csv
I currently open them in the same work book, put the titles in A, the hyperlinks in H, and use
=HYPERLINK(H1,A1)
to get my final output of Titles with hyperlinks built in.
Is there an easy way (Excel VBA or macro) to bypass the manual work and create a new output file with the "Titles with hyperlinks built in" from the original two .csv files?
Edit: My two .csv files have the respective text (hyperlink and titles) all down column A.
Sub buildlinks()
Dim i As Integer
Dim wb1, wb2 As Workbook
Set wb1 = Application.Workbooks.Open("C:/path/Links.csv")
Set wb2 = Application.Workbooks.Open("C:/path/Titles.csv")
i = 1
Do Until wb1.Sheets("Sheet1Name").Cells(i, 1).Value = ""
ThisWorkbook.Sheets("Sheet1Name").Cells(i, 1).Formula = "=HYPERLINK(" & wb1.Sheets("Sheet1Name").Cells(i, 1).Value & "," & wb2.Sheets("Sheet1Name").Cells(i, 1).Value & ")"
i = i + 1
Loop
End Sub
Assuming you want to create the hyperlinks in the current spreadsheet instead of creating a separate file.
Since you've said that the inputs are really just text files, one item per line, not comma-separated, it's actually pretty simple to implement using the VBA file handling commands.
Sub BuildLinks(titlesFilePath as String, linksFilePath As String, ByVal rowStart As Long)
Dim tf As Long, lf As Long, of As Long
tf = FreeFile
On Error Goto NO_TITLE_FILE
Open titlesFilePath For Input As #tf
lf = FreeFile
On Error Goto NO_LINKS_FILE
Open linksFilePath For Input As #lf
On Error Goto 0
While Not (EOF(tf) Or EOF(lf))
Dim curTitle As String, curLink As String
Line Input #tf, curTitle
Line Input #lf, curLink
Cells(rowStart, 1).Formula = "=HYPERLINK(""" & curLink & """,""" & curTitle & """)"
Wend
Close #tf
Close #lf
Exit Sub
NO_TITLE_FILE:
MsgBox "Can't Open Title File" & titlesFilePath
Exit Sub
NO_LINKS_FILE:
MsgBox "Can't Open Links File" & linksFilePath
End Sub