I have a bunch of data in excel that I need to write to txt, that I have to import in an other program. This software has a very specific format, and I have no idea how to create a code that will do it exactly as I need it.
Excel:
This is just an example, there are more columns and the actual version and the amount of lines also varies.
In the result text file this should look like this:
txt:
So it needs the id from line 2, followed by the lines number in brackets then equal sign and the associated name or date in this example.
Is there any way to do this?
You can use some looping through cells on the Excel sheet together with some VBA File Input/Output to achieve this. Below is some code that works correctly on the sample data provided, and should get you pointed in the right direction:
Sub sExportPersonData()
On Error GoTo E_Handle
Dim ws As Worksheet
Dim intFile As Integer
Dim strFile As String
Dim lngLastRow As Long
Dim lngLastCol As Long
Dim lngRowLoop As Long
Dim lngColLoop As Long
Dim strOutput As String
intFile = FreeFile
strFile = "J:\downloads\person.txt"
Open strFile For Output As intFile
Set ws = ThisWorkbook.Worksheets("Sheet1")
lngLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lngLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For lngRowLoop = 3 To lngLastRow
For lngColLoop = 2 To lngLastCol
strOutput = ws.Cells(2, lngColLoop) & "[" & ws.Cells(lngRowLoop, 1) & "]=" & ws.Cells(lngRowLoop, lngColLoop)
Print #intFile, strOutput
Next lngColLoop
Next lngRowLoop
sExit:
On Error Resume Next
Close #intFile
Set ws = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sExportPersonData", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards,
Related
Hello i have macro where download all attachments from multiple emails, this code works fine, but I need change code to change every file name where was downloaded in folder, files name like "I10001258", "I10003256", "I10004758"... I wanna delete first five letters "I10001258", for all downloading files. Thanks!
Option Explicit
Sub Get_Attachments()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")
Dim msg As Outlook.MailItem
Dim fo As Outlook.Folder
Dim at As Outlook.Attachment
Set fo = Outlook.GetNamespace("MAPI").Folders("Your Mail Box Name Here").Folders("Inbox").Folders("My Report")
Dim lr As Integer
For Each msg In fo.Items
lr = Application.WorksheetFunction.CountA(sh.Range("A:A"))
sh.Range("A" & lr + 1).Value = msg.Subject
sh.Range("B" & lr + 1).Value = msg.Attachments.Count
For Each at In msg.Attachments
If VBA.InStr(at.Filename, ".xls") > 0 Then
at.SaveAsFile sh.Range("F1").Value & "\" & at.Filename
End If
Next
Next
MsgBox "Reports have been downloaded successfully"
End Sub
Mid() can be used to skip the first characters.
at.SaveAsFile sh.Range("F1").Value & "\" & Mid(at.Filename, 6)
Thanks for all the help given here.
I am by no means a coder and spend hours searching forums and canabilising bits of code to create what I need. I built the below code to extract data from one workbook, based on the filter and then save as in a individual workbooks. This code worked really well for one workbook, but now I've tried to reuse it,it throws a 1004 runtime error when trying to save as. Any idea where it could be going wrong?
Many thanks,
Stephen
Sub Split()
Dim ws As Worksheet
Dim wsNew As Workbook
Dim rData As Range
Dim rfl As Range
Dim state As String
Dim myValue As Variant
Dim sfilename As String
Dim FolderName As String
Dim strDir As String
myValue1 = InputBox("What date is this save for? (Format: DD Month)")
Range("B1").Select
Selection.AutoFilter
Set ws = ThisWorkbook.Sheets("Combined Data")
With ws
Set rData = .Range(.Cells(1, 2), .Cells(.Rows.Count, 13).End(xlUp))
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
MsgBox "Please select the folder to save files"
FolderName = GetFolder()
If FolderName = "" Then
MsgBox "No folder was selected. Program will terminate."
Exit Sub
End If
For Each rfl In .Range(.Cells(2, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
state = rfl.Text
strDir = FolderName & "\" & state
If Dir(strDir, vbDirectory) = "" Then
MkDir strDir
Else
End If
Set wsNew = Workbooks.Add
sfilename = "Monday" & " " & myValue1 & " - Engagement" & ".xlsx"
ActiveWorkbook.SaveAs strDir & "\" & sfilename
You need to find out the actual reason for this common error code - 1004. Edit your function/VBA code and run your program in debug mode to identify the line which is causing it. And then, add below piece of code to see the error,
On Error Resume Next
// your code goes here which causes 1004 error
If Err.Number > 0 Then
Debug.Print Err.Number & ":" & Err.Description
End If
I'd suggest using debug shortcut keys on your keyboard - Step Into (F8), Step Over (Shift + F8), Step Out (Ctrl + Shift + F8)
I am using the below code to cycle through data in a spreadsheet to create an XML file:
Private Sub btn_Submit_Click()
Dim colIndex As Integer
Dim rwIndex As Integer
Dim asCols() As String
Dim oWorkSheet As Worksheet
Dim sName As String
Dim lCols As Long, lRows As Long
Dim iFileNum As Integer
Dim str_switch As String ' To use first column as node
Dim blnSwitch As Boolean
Dim rng As Range
For Each rng In ActiveSheet.UsedRange
If Application.WorksheetFunction.IsText(rng) Then
i = i + 1
End If
Next rng
Set oWorkSheet = ThisWorkbook.Worksheets("Sheet1")
sName = oWorkSheet.Name
lCols = i
iFileNum = FreeFile
Open "C:\temp\test2.xml" For Output As #iFileNum
Print #iFileNum, "<?xml version=""1.0""?>"
Print #iFileNum, "<" & sName & ">" ' add sheet name to xml file as First Node
i = 1
Do Until i = lCols + 1
Print #iFileNum, " <" & oWorkSheet.Cells(1, i).Text & ">" & Trim(oWorkSheet.Cells(2, i).Value) & "</" & oWorkSheet.Cells(1, i).Text & ">"
i = i + 1
Loop
Print #iFileNum, "</" & sName & ">"
Close #iFileNum
MsgBox ("Complete")
ErrorHandler:
If iFileNum > 0 Then Close #iFileNum
Exit Sub
End Sub
This process is working perfectly to create the tag names I want, and inserting the text entered. The problem arises where I need to insert an attachment which is stored in one of the cells using the following little chunk of code:
Set rng = Range("AH2") 'Name the cell in which you want to place the attachment
rng.RowHeight = 56
On Error Resume Next
fpath = Application.GetOpenFilename("All Files,*.*", Title:="Select file", MultiSelect:=True)
For i = 1 To UBound(fpath)
rng.Select
rng.ColumnWidth = 12
ActiveSheet.OLEObjects.Add _
Filename:=fpath(i), _
Link:=False, _
DisplayAsIcon:=True, _
IconFileName:="excel.exe", _
IconIndex:=0, _
IconLabel:=extractFileName(fpath(i))
Set rng = rng.Offset(0, 1)
Next i
MsgBox ("Document Uploaded")
For some reason, the document is not appearing in its relevant tag. Does anyone know where I am going wrong, or if I am attempting the impossible!
You have to declare variable type of OleObject:
Dim ol As OLEObject
Then, inside a for next loop:
Set ol = ActiveSheet.OLEObjects.Add(....)
With ol
.Top = rng.Top
.Left = rng.Left
End With
For further details, please see: vba macro to embed OLEobject based on cell
I was using the script which I found here : https://excelribbon.tips.net/T008349_Counting_All_Characters.html
It is working as expected however when there are some other objects like pictures, the script returns me the error 438"Object Doesn't Support This Property or Method".
When I deleted the pictures the script was working well again.
Is there an option to put in the script something like "ignore pictures"? Or is there any better type of script to achieve this? I am not good at all at VBA, all help will be much appreciated.
Here's a simplified approach that may work out a bit better. I think being explicit which Shape Types you want to count is going to be a cleaner way of going about this.
Option Explicit
Private Function GetCharacterCount() As Long
Dim wks As Worksheet
Dim rng As Range
Dim cell As Range
Dim shp As Shape
For Each wks In ThisWorkbook.Worksheets
For Each shp In wks.Shapes
'I'd only add the controls I care about here, take a look at the Shape Type options
If shp.Type = msoTextBox Then GetCharacterCount = GetCharacterCount + shp.TextFrame.Characters.Count
Next
On Error Resume Next
Set rng = Union(wks.UsedRange.SpecialCells(xlCellTypeConstants), wks.UsedRange.SpecialCells(xlCellTypeFormulas))
On Error GoTo 0
If not rng Is Nothing Then
For Each cell In rng
GetCharacterCount = GetCharacterCount + Len(cell.Value)
Next
end if
Next
End Function
Sub CountCharacters()
Debug.Print GetCharacterCount()
End Sub
It looks like you can add an if-check like the one here (VBA Code to exclude images png and gif when saving attachments for "PNG" and "GIF".).
You just have to change the if-check to check for the picture type you're using "JPG" or "JPEG"? Simply match the extension to the if-check by replacing "PNG" or "GIF" with your extension in CAPS.
Add the if-check right above where the error is occurring or better yet, add it above the scope of where the error is occurring.
I took the script from your link and modified it. Now it works.
It's far from perfect (there're some cases where it can still crash), but now it supports handling Shapes with no .TextFrame property:
Sub CountCharacters()
Dim wks As Worksheet
Dim rng As Range
Dim rCell As Range
Dim shp As Shape
Dim bPossibleError As Boolean
Dim bSkipMe As Boolean
Dim lTotal As Long
Dim lTotal2 As Long
Dim lConstants As Long
Dim lFormulas As Long
Dim lFormulaValues As Long
Dim lTxtBox As Long
Dim sMsg As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
lTotal = 0
lTotal2 = 0
lConstants = 0
lFormulas = 0
lFormulaValues = 0
lTxtBox = 0
bPossibleError = False
bSkipMe = False
sMsg = ""
For Each wks In ActiveWorkbook.Worksheets
' Count characters in text boxes
For Each shp In wks.Shapes
If TypeName(shp) <> "GroupObject" Then
On Error GoTo nextShape
lTxtBox = lTxtBox + shp.TextFrame.Characters.Count
End If
nextShape:
Next shp
On Error GoTo ErrHandler
' Count characters in cells containing constants
bPossibleError = True
Set rng = wks.UsedRange.SpecialCells(xlCellTypeConstants)
If bSkipMe Then
bSkipMe = False
Else
For Each rCell In rng
lConstants = lConstants + Len(rCell.Value)
Next rCell
End If
' Count characters in cells containing formulas
bPossibleError = True
Set rng = wks.UsedRange.SpecialCells(xlCellTypeFormulas)
If bSkipMe Then
bSkipMe = False
Else
For Each rCell In rng
lFormulaValues = lFormulaValues + Len(rCell.Value)
lFormulas = lFormulas + Len(rCell.Formula)
Next rCell
End If
Next wks
sMsg = Format(lTxtBox, "#,##0") & _
" Characters in text boxes" & vbCrLf
sMsg = sMsg & Format(lConstants, "#,##0") & _
" Characters in constants" & vbCrLf & vbCrLf
lTotal = lTxtBox + lConstants
sMsg = sMsg & Format(lTotal, "#,##0") & _
" Total characters (as constants)" & vbCrLf & vbCrLf
sMsg = sMsg & Format(lFormulaValues, "#,##0") & _
" Characters in formulas (as values)" & vbCrLf
sMsg = sMsg & Format(lFormulas, "#,##0") & _
" Characters in formulas (as formulas)" & vbCrLf & vbCrLf
lTotal2 = lTotal + lFormulas
lTotal = lTotal + lFormulaValues
sMsg = sMsg & Format(lTotal, "#,##0") & _
" Total characters (with formulas as values)" & vbCrLf
sMsg = sMsg & Format(lTotal2, "#,##0") & _
" Total characters (with formulas as formulas)"
MsgBox Prompt:=sMsg, Title:="Character count"
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
If bPossibleError And Err.Number = 1004 Then
bPossibleError = False
bSkipMe = True
Resume Next
Else
MsgBox Err.Number & ": " & Err.Description
Resume ExitHandler
End If
End Sub
You could try:
Option Explicit
Sub test()
Dim NoOfChar As Long
Dim rng As Range, cell As Range
NoOfChar = 0
For Each cell In ThisWorkbook.Worksheets("Sheet1").UsedRange '<- Loop all cell in sheet1 used range
NoOfChar = NoOfChar + Len(cell.Value) '<- Add cell len to NoOfChar
Next cell
Debug.Print NoOfChar
End Sub
Today I have a problem of trying to write a csv file line by line with one of the columns formatted as a native excel date. My script works but doesn't export the date correctly and is being exported as as serial string. I simply want the exported file to write the date in the "mm/dd/yyyy" format. Any ideas?
Sub OUTPUT_COMMA_DELIMITED_RANGE()
Dim outputPath As String
Dim outputFileName As String
Dim rSrc As Range
Dim rSrcRow As Range
Dim fso As FileSystemObject
Dim fOut As TextStream
On Error GoTo SomethingBadHappened
Dim MyPathFull As String
outputPath = "C:\workspace\Appendix_Working_Area\Script_Out\"
outputFileName = "Z225R" & Chr(95) & "Eddy_Fluctuating_Zone.csv"
MyPathFull = outputPath & outputFileName
Set fso = CreateObject("scripting.filesystemobject")
Set fOut = fso.CreateTextFile(outputPath & outputFileName)
Dim EddyHghEleZoneRng As Range
Set EddyHghEleZoneRng = Worksheets("225R").Range(Cells(1, 9), Cells(1, 9).End(xlToRight).End(xlDown))
Set rSrc = EddyHghEleZoneRng
For Each rSrcRow In rSrc.Rows
fOut.WriteLine Join(Application.WorksheetFunction.Transpose _
(Application.WorksheetFunction.Transpose(rSrcRow)), ",")
Next rSrcRow
MsgBox "File " & outputPath & outputFileName & " created successfully"
SomethingBadHappened:
If Err.Number <> 0 Then MsgBox Err.Description
On Error Resume Next
fOut.Close
If Err.Number <> 0 And Err.Number <> 91 Then MsgBox "Unable to close file (" & Err.Description & ")"
End Sub
I have chosen to manually create the csv file because id don't want any of the unwanted characters associated with using the FileFormat:=xlCSV feature built in to excel.
To provide a sample of the kind of data i am dealing i have created an example of what i want the output csv file too look like.
Site,Date,Plane_Height,Area_2D,Area_3D,Volume,Errors
225r,11/3/1990,8kto25k,2212.834,2235.460,841.76655,88.513
Thanks,
dubbbdan
It appears that your data is contained in 6 columns. Here is a way to make a .csv which preserves date formats:
Sub MakeCSVFile()
Dim N As Long, M As Long, i As Long, j As Long
Dim OutRec As String
N = Cells(Rows.Count, "A").End(xlUp).Row
M = 6
Close #1
Open "C:\TestFolder\x.csv" For Output As #1
For i = 1 To N
OutRec = Cells(i, 1).Text
For j = 2 To M
OutRec = OutRec & "," & Cells(i, j).Text
Next j
Print #1, OutRec
Next i
Close #1
End Sub