I am trying to figure out how to check that the layout (not the full content) of a CSV file is the same of that in the preceding month (or, if that file doesn't exist, the last available CSV file).
Often companies change the format/layout of their CSV extracts, so I want my code to automatically detect any changes (new columns added, changing order of columns, etc).
Please let me know if you have an idea of how this could be achieved!
Thanks in advance!
Please, try the next code. It assumes that the csv to be compared is comma separated and ending lines are vbCrLf:
Private Sub CheckCSVfile()
Dim ws As Worksheet, strFile As String, ans As VbMsgBoxResult, sep As String
Dim arrRef, arrCSV, cols, i As Long, strProbl As String
ans = MsgBox("Is the active sheet the one you wan to use as reference to compare the CSV file structure?" & vbCrLf & _
"If this is the situation, please press ""Yes""!", vbYesNo, "Confirm the active sheet as reference")
If ans <> vbYes Then Exit Sub
Set ws = ActiveSheet
'Put the first sheet row values in an array (2D array):
arrRef = ws.Range(ws.cells(1, 1), ws.cells(1, ws.cells(1, ws.Columns.count).End(xlToLeft).Column)).value
''Browse for the .csv file to be checked:
strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select the csv file to be checked.")
If strFile = "False" Then Exit Sub
'Put the content of the csv file in an array (split by the line ending separator). If not vbCrLf, use the appropriate one:
arrCSV = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(strFile, 1).ReadAll, vbCrLf)
sep = "," 'the csv file separator. Use here the correct one if not comma
cols = Split(arrCSV(0), sep) 'number of columns of the first csv file row (zero based array)
If UBound(cols) + 1 <> UBound(arrRef, 2) Then '+ 1 for the first array because it is of 0 based type
strProbl = strProbl & "The number of columns in the new csv file is different (" & UBound(cols) & " against " & UBound(arrRef) & ")." & vbCrLf
End If
'Comparing each header:
For i = 0 To UBound(arrRef, 2) - 1
If UCase(arrRef(1, i + 1)) <> UCase(cols(i)) Then
strProbl = strProbl & "The value in the column " & i + 1 & " is different (" & cols(i) & " against " & arrRef(1, i + 1) & ")" & vbCrLf
End If
Next i
Stop
If strProbl <> "" Then
MsgBox "The new csv file has a different structure: " & vbCrLf & vbCrLf & strProbl, vbCritical, "Structure problems..."
Else
MsgBox "The both files structure is the same!", vbInformation, "No any structure problem"
End If
End Sub
You must firstly open and activate the sheet of the previous csv file (to be used as reference) and then run the above code.
Please, send some feedback after testing it...
Related
I've had the hardest time figuring out the below code
I am trying to save many files over the course of a day into one directory with the same name, except with a number that marks it in a successive fashion.
I have searched stackoverflow, but cannot seem to understand where I put the Save As line, within the loop to increment by one? Well, that didn't work and neither did many other tries.
Please kindly advise on this :)
Sub AutoSave()
Dim filename As String, filepath As String, filecount As Integer, filedate
As String
filedate = Format(Now(), "MM-DD-YYYY")
filepath = "C:\Users\nabil\OneDrive\Documents"
filecount = filecount + 1
Set book = Workbooks.Open("Nabil 06-06-2019 #1 Lincoln.xlsx")
' code to copy and paste here
If Len(Dir(filepath & filename)) <> 0 Then
filecount = filecount + 1
filename = "Nabil " & filedate & " " & "#" & filecount & " " & "Lincoln"
ActiveWorkbook.SaveAs filename:= _ "C:\Users\nabil\OneDrive\Documents\Nabil
" & filedate & " " & "#" & filecount & " " & "Lincoln" & ".xlsx"
End If
End Sub
Thanks for the help Mathieu. I have now edited it like this above
But now it does not want to Save As , when I put the save as in the loop or if-then statement. If I put it after the loop , then it prompts me to save over the existing file name, not saving as the file name with an increment of 1 (.e.g, #2)
This is a sliver of the code I'm using which requires that I operate from the macro workbook and open a blank template and paste data onto it , and then save as throughout the day
Please kindly advise :)
I am trying to rename a file using based on a list in excel such that column A has old file name and Column B has new file name. It worked for some files but its not renaming some files.
THis is the macro that I used:
Sub RenameFiles()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "B").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
Here is a screenshot of my excel file names:
Can anyone tell me whats the issue here ?
Any help would be appreciated. Thanks in advance
I have undergone with similar requirement. I solved it using bit different approach.
Here's is exactly what I did:
1) I create Excel similar to yours.
2) Column A will have Old Filename
3) Column B will have New Filename
4) I will write DOS Command in Column C, using Excel Formula.
Once done, I will copy the data from Column C and create a BATCH File out of it. Once I run the BATCH File, it gets my work done. This formula assumes that you don't have any special characters.
Sharing the formula that I wrote in Column C:
="REN " & CHAR("34") & A2 & CHAR(34) & " " & CHAR(34) & B2 & "" & CHAR(34)
And also adding screenshot of my Excel as reference.
Is it possible to turn an SRT file, which is used for subtitles in videos into a dataset?
When imported into Excel, the SRT file format looks like this:
1
00:00:03,000 --> 00:00:04,000
OVERLAPS PURE COINCIDENCE THAT
...
This pattern continues as time in the "video"/transcript goes on. I'd like to format the SRT file this way:
number ; start ; end ; text
1 ; 00:00:03,000 ; 00:00:04,000 ; OVERLAPS PURE COINCIDENCE THAT
The VBA procedure below loads a standard .srt (SubRip Movie Subtitle File) from a local file and splits it into rows/columns on the active Excel worksheet.
Import SRT subtitles from Local File:
Sub importSRTfromFile(fName As String)
'Loads SRT from local file and converts to columns in Active Worksheet
Dim sIn As String, sOut As String, sArr() As String, x As Long
'load file
Open fName For Input As #1
While Not EOF(1)
Line Input #1, sIn
sOut = sOut & sIn & vbLf
Wend
Close #1
'convert LFs to delimiters & split into array
sOut = Replace(sOut, vbLf & vbLf, vbCr)
sOut = Replace(Replace(sOut, vbLf, "|"), " --> ", "|")
sArr = Split(sOut, vbCr)
'check if activesheet is blank
If ActiveSheet.UsedRange.Cells.Count > 1 Then
If MsgBox(UBound(sArr) & " rows found." & vbLf & vbLf & _
"Okay to clear worksheet '" & ActiveSheet.Name & "'?", _
vbOKCancel, "Delete Existing Data?") <> vbOK Then Exit Sub
ActiveSheet.Cells.ClearContents
End If
'breakout into rows
For x = 1 To UBound(sArr)
Range("A" & x) = sArr(x)
Next x
'split into columns
Columns("A:A").TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, Other:=True, OtherChar:="|"
MsgBox "Imported " & UBound(sArr) & " rows from:" & vbLf & fName
End Sub
Example Usage:
Sub test_FileImport()
importSRTfromFile "c:\yourPath\yourFilename.srt"
End Sub
Import SRT subtitles from Website URL:
Alternatively, you can import an .srt (or other similar text files) from a Website URL such as https://subtitle-index.org/ with this:
Sub importSRTfromWeb(url As String)
'Loads SRT from URL and converts to columns in Active Worksheet
Dim sIn As String, sOut As String, sArr() As String, rw As Long
Dim httpData() As Byte, XMLHTTP As Object
'load file from URL
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
XMLHTTP.Open "GET", url, False
XMLHTTP.send
httpData = XMLHTTP.responseBody
Set XMLHTTP = Nothing
sOut = StrConv(httpData, vbUnicode)
'convert LFs to delimiters & split into array
sOut = Replace(sOut, vbLf & vbLf, vbCr)
sOut = Replace(Replace(sOut, vbLf, "|"), " --> ", "|")
sArr = Split(sOut, vbCr)
'check if activesheet is blank
If ActiveSheet.UsedRange.Cells.Count > 1 Then
If MsgBox(UBound(sArr) & " rows found." & vbLf & vbLf & _
"Okay to clear worksheet '" & ActiveSheet.Name & "'?", _
vbOKCancel, "Delete Existing Data?") <> vbOK Then Exit Sub
ActiveSheet.Cells.ClearContents
End If
'breakout into rows
For rw = 1 To UBound(sArr)
Range("A" & rw) = sArr(rw)
Next rw
'split into columns
Columns("A:A").TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, Other:=True, OtherChar:="|"
MsgBox "Imported " & UBound(sArr) & " rows from:" & vbLf & url
End Sub
Example Usage:
Sub testImport()
importSRTfromWeb _
"https://subtitle-index.org/download/4670541854528212663953859964/SRT/Pulp+Fiction"
End Sub
Many sites host free .srt's; you may have to right-click the download button to copy the link (which may have an .srt extension or might be a pointer, like the example above). The procedure won't work on .zip'd files.
More Information:
Wikipedia : SubRip & SRT
MSDN : Split Function (VBA)
Wikipedia : Newline characters
MSDN : UBound Function
MSDN : Range.TextToColumns Method (Excel)
SubRip Official Website
in the above code :
'breakout into rows
For rw = 1 To UBound(sArr)
Range("A" & rw) = sArr(rw)
Next rw
should be replaced with:
'breakout into rows
For rw = 0 To UBound(sArr)
Range("A" & rw+1) = sArr(rw)
Next rw
else the output will start from line 2
I used Vim and wrote a quick regex to convert a .srt into a .csv file for a translator friend who needed a similar conversion. The csv file can then be opened in Excel / LibreOffice and saved as .xls, .ods or whatever.
My friend didn't need the subtitle numbers to appear in the first column so the regex code looks like this :
set fileencoding=utf-8
%s/"/""/g
g/^\d\+$/d
%s#^\(.*\) --> \(.*\)\n#"\1","\2","#g
%s/\n^$/"/g
Variant to keep the sub numbering :
set fileencoding=utf-8
%s/"/""/g
%s#\(^\d\+\)$\n^\(.*\) --> \(.*\)\n#"\1","\2","\3","#g
%s/\n^$/"/g
Save this code into a text file with the .vim extension, then source this file when editing your .srt in Vim / Gvim. Save the result as a .csv. Enjoy the magic of Regexes !
NB : my code uses commas as field separators. Change the commas into semi-colons in the above code to use semi-colons. I've also added double-quotes as string delimitors in case double-quotes and commas occur in the subtitle text. Much more error proof !
I am new to Macro
By googling I coded this and I have changed some part for my use.
Problem is Runtime error is coming. And I don't know how to print all word documents in folder both .doc and .docx
My Requirement
Want to print all word document in folder A (both .doc and .docx).
Print active document ( Number of copies want to be get from User ).
Close active document.
Repeat 2 and 3 for all document in folder A
My code will get page number to print from case selected by the user
case 1 will print 1st two pages one by one.
case 2 will print 3rd to reset of the pages.
case 3 will print full document.
In my office duplex is default printer setup to print. But I will be using letter head. I need this macro to solve my issue. I tried simplex macro code to print but its not working.
Sub prnt()
Dim c As Integer
Dim i As Integer
Dim strName As String
'get print type
strName = InputBox(Prompt:="Choose Your Option" & vbNewLine & "" & vbNewLine & "1. Letter Head" & vbNewLine & "2. A4 Sheet" & vbNewLine & "3. Comp Plan" & vbNewLine & "", _
Title:="ENTER YOUR PRINT TYPE", Default:="Your Choice here")
If strName = "Your Choice here" Or strName = vbNullString Then
MsgBox "Sorry...! Choose Correct option"
Exit Sub
Else
'case to choose option
Select Case strName
Case "1"
Dim file
Dim path As String
Dim ans As String
'get number of copies from user
c = InputBox("Please enter number of copies")
ans = MsgBox("Are you sure you want to print " & _
c & "?", _
vbQuestion + vbYesNo, "Print pages")
If ans = vbNo Then
Exit Sub
Else
'path to the folder
path = "E:\print\"
file = Dir(path & "*.docx")
Do While file ""
Documents.Open Filename:=path & file
For i = 1 To 2 'loop 2 pages
ActiveDocument.PrintOut , Copies:=c, Range:=wdPrintRangeOfPages, Pages:=i
Next
ActiveDocument.Close
' set file to next in Dir
file = Dir()
Loop
End If
Case "2"
Case "3"
Case Else
MsgBox "Sorry...! Choose Correct option"
End Select
End If
End Sub
There's bad programming practice to work on strings instead of numbers.
See this:
Sub Test()
Dim noofcopies As Integer
noofcopies = GetNumberOfCopies()
MsgBox noofcopies
End Sub
Function GetNumberOfCopies() As Integer
Dim iRetVal As Integer
On Error GoTo Err_GetNumberOfCopies
iRetVal = CInt(InputBox("Enter no. of copies to print" & vbCr & vbCr & _
"Enter proper integer value between 1 and 3" & vbCr & _
"0 (zero) equals to Cancel", "No. of copies", "1"))
If iRetVal > 3 Then iRetVal = 3
Exit_GetNumberOfCopies:
GetNumberOfCopies = iRetVal
Exit Function
Err_GetNumberOfCopies:
Err.Clear
Resume 0
End Function
Use the same logic to get print option ;)
Could someone please help me out with a way to loop through the directory of the current file and search for the file to see if it exists, if it does then count the number of files with version numbers already and increment the next number, if it does not exist then create the file like normal.
Basically I have a vba macro that allows you to extract a slide pack from a 'master template' which they are all stored. The user clicks on the pack that they want and the pack gets extracted and saved out into that same directory. My problem is there is no version control or file protection setup. Could someone please help me work out how to do a loop and increment the version numbers.
Option Explicit
Public Sub CreatePack(control As IRibbonControl)
Dim packName As String
Dim Count As Integer
Select Case control.Id
Case "packbutton_B1"
packName = "B1"
Case "packbutton_B2"
packName = "B2"
Case "packbutton_TSD"
packName = "TSD"
End Select
'Note: Attempt to remove characters that are not file-system friendly
Dim Title As String
If ActivePresentation.Slides(1).Shapes.Count >= 9 Then
Title = Trim(ActivePresentation.Slides(1).Shapes(9).TextEffect.Text)
If Title = "" Then MsgBox "Warning: A project title has not been entered on Slide 1."
Else
Title = "(Project Title Not Known)"
MsgBox "The title slide has been removed, the project name cannot be detected."
End If
Title = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Title, "/", ""), "\", ""), ":", ""), "*", ""), "<", ""), ">", ""), "|", ""), """", "")
Dim path As String
path = ActivePresentation.path
If Len(Dir(path & "\" & packName & " Slide Pack - " & Title & ".pptx")) > 0 Then 'File exists
' If MsgBox("This will produce a pack in a separate PowerPoint file. Before extracting the pack make sure you have implemented a version number otherwise your changes maybe overwritten." & vbCrLf & vbCrLf & "Your current file will remain open, and any pending changes will not be automatically saved.", vbOKCancel, "Slide Manager - Create Pack") = vbOK Then
MsgBox ("File exists, the file name version number will be incremented")
CopySlidesToBlankPresentation packName
Application.ActivePresentation.SaveAs path & "\" & packName & " Slide Pack - " & Title & Count + 1, ppSaveAsOpenXMLPresentation
ActivePresentation.Save
Else
MsgBox ("This will produce a pack in a separate PowerPoint file." & vbCrLf & vbCrLf & "Your current file will remain open, and any pending changes will not be automatically saved")
CopySlidesToBlankPresentation packName
Application.ActivePresentation.SaveAs path & "\" & packName & " Slide Pack - " & Title, ppSaveAsOpenXMLPresentation
ActivePresentation.Save
End If
End Sub
Any help is greatly appreciated!
Regards,
Ben
If I understand your question correctly your loop should look something like this
Dim fileNoVersion As String
fileNoVersion = path & "\" & packName & " Slide Pack - " & Title
Dim count As Integer
count = 1
While Dir(fileNoVersion & count & ".pptx") <> ""
count = count + 1
Wend
This checks which files Version1, Version2, Version3... exist and returns the next unused number.