I'm trying to write a VBA macro that changes file names from the text in Column B to the text of Column A. For example, if I had:
Column A: Stack Overflow
Column B: Question
It would change Question.txt to Stack Overflow.txt. As of now I've slightly modified the code from the answer here to read:
Sub rename()
Dim Source As Range
Dim OldFile As String
Dim NewFile As String
Set Source = Cells(1, 1).CurrentRegion
For Row = 2 To Source.Rows.Count
OldFile = ActiveSheet.Range("D1").Value & ("\") & ActiveSheet.Cells(Row, 1) & (".pdf")
NewFile = ActiveSheet.Range("D1").Value & ("\") & ActiveSheet.Cells(Row, 2) & (".pdf")
' rename files
Name OldFile As NewFile
Next
End Sub
This works great, but I'm trying to get it to only run on selected rows; my ideal end result is that I can select the 15 non-consecutive rows that I want to change, run the macro, and have it only apply to those 15. I tried the below code but the ActiveSheet.Cells(Row, 1) function is returning a Run-Time Error 1004, Application-defined or object-definied error; is there a good way around this?
Sub renameMain()
Dim OldFile As String
Dim NewFile As String
Dim rng As Range
Set rng = Selection
For Each Row In rng
OldFile = ActiveSheet.Range("O1").Value & "\" & ActiveSheet.Range(Row, 2) & ".pdf"
NewFile = ActiveSheet.Range("O1").Value & "\" & ActiveSheet.Range(Row, 1) & ".pdf"
' rename files
Name OldFile As NewFile
Next Row
End Sub
Any advice would be much appreciated!
Non contiguous rows in the Selection object can be accessed using its .Areas collection:
Option Explicit
Sub renameMain()
Dim oldFile As String, newFile As String
Dim selArea As Range, selRow As Range, staticVal As String
With ActiveSheet
staticVal = .Range("O1").Value2 & "\"
For Each selArea In Selection.Areas
For Each selRow In selArea.Rows
oldFile = staticVal & .Cells(selRow.Row, 2).Value2
newFile = staticVal & .Cells(selRow.Row, 1).Value2
Name oldFile & ".pdf" As newFile & ".pdf" 'rename files
Next
Next
End With
End Sub
You seem to want to use Row as an int variable. It isn't. Maybe try this:
Sub renameMain()
Dim OldFile As String
Dim NewFile As String
Dim rng As Range
Dim i as long
Set rng = Selection
For i = 1 To rng.Rows.Count
OldFile = ActiveSheet.Range("O1").Value & "\" & rng.Cells(i, 2) & ".pdf"
NewFile = ActiveSheet.Range("O1").Value & "\" & rng.Cells(i, 1) & ".pdf"
' rename files
Name OldFile As NewFile
Next i
End Sub
Related
I've managed to piece together this VBA which takes data from excel and turns it into .txt flat file. It works exactly as I need, but I would like to alter it so that the end result is saved as Unicode as opposed to ANSI.
I've done some reading and the answer I keep coming back to is to use FileSystemObject. I found a VBA on here that does the job perfectly, but I can't for the life of me work out how to incorporate it into my existing code. Any chance someone could throw me some pointers?
This is my current code:
' Defines everything first. So, from B2, across and down.
LastRow = Sheets("Pricing").Range("B" & Rows.Count).End(xlUp).Row
LastColumn = Sheets("Pricing").Cells(2, Columns.Count).End(xlToLeft).Column
' File name, path to save to and delimiter.
file = Sheets("Pricing").TextBox1 & ".txt"
If TextBox1.Value = "" Then MsgBox "What we calling it genius?", vbQuestion
If TextBox1.Value = "" Then Exit Sub
Path = "C:\Users\me.me\Desktop\Files\"
Delimeter = "|"
' The magic bit.
myFileName = Path & file
FN = FreeFile
Open myFileName For Output As #FN
For Row = 2 To LastRow
For Column = 2 To LastColumn
If Column = 2 Then Record = Trim(Cells(Row, Column)) Else Record = Record & Delimeter & Trim(Cells(Row, Column))
Next Column
Print #FN, Record
Next Row
Close #FN
MsgBox "BOOM! LOOKIT ---> " & myFileName
' Opens the finished file.
Dim fso As Object
Dim sfile As String
Set fso = CreateObject("shell.application")
sfile = "C:\Users\me.me\Desktop\Files\" & Sheets("Pricing").TextBox1 & ".txt"
fso.Open (sfile)
And this is what I've been trying to incorporate (HUGE thanks to MarkJ for posting this on another question):
Dim fso As Object, MyFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile("c:\testfile.txt", False,True) 'Unicode=True'
MyFile.WriteLine("This is a test.")
MyFile.Close
I just can't get it to work.
Please, test the next code. You did not answer my clarification question, but it works using the above comment assumptions. It take the file name, from an activeX text box situated on the sheet to be processed. The code should be faster than yours for big ranges, avoiding to iterate between all cells:
Sub SaveAsUnicode()
Dim shP As Worksheet, iRow As Long, Record As String, Delimeter As String
Dim file As String, myFileName As String, path As String, txtB As MSForms.TextBox
Dim rng As Range, lastCell As Range, arr, arrRow
Dim fso As Object, MyFile As Object, shApp As Object
Set shP = Worksheets("Pricinig")
Set txtB = shP.OLEObjects("TextBox1").Object 'it sets an activeX sheet text box
file = txtB.Text & ".txt"
If txtB.value = "" Then MsgBox "What we calling it genius?", vbQuestion: Exit Sub
Set lastCell = shP.cells.SpecialCells(xlCellTypeLastCell) 'last cell of the sheet
Set rng = shP.Range("A2", lastCell) 'create the range to be processed
arr = rng.value 'put the range in an array
path = "C:\Users\me.me\Desktop\Files\" 'take care to adjust the path!
myFileName = path & file
Delimeter = "|"
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(myFileName, False, True) 'open the file to write Unicode:
For iRow = 1 To UBound(arr) 'itereate between the array rows
arrRow = Application.Index(arr, iRow, 0) 'make a slice of the currrent arrray row
Record = Join(arrRow, Delimeter) 'join the iD obtained array, using the set Delimiter
MyFile.WriteLine (Record) 'write the row in the Unicode file
Next iRow
MyFile.Close 'close the file
'open the obtained Unicode file:
Set shApp = CreateObject("shell.application")
shApp.Open (myFileName)
End Sub
I tested the above code on a sheet using characters not supported in ANSI and it works as expected.
Please, send some feedback after testing it, or if my assumptions after reading your question are not correct...
#FaneDuru, this is what I ended up putting together, it's working great for me. Thanks again for all of your help.
Private Sub FlatButton_Click()
'Does all the setup stuff.
Dim fso As Object, MyFile As Object
Dim MyFileName As String
Dim txtB As MSForms.TextBox
Set shP = Worksheets("Pricing")
Set txtB = shP.OLEObjects("TextBox1").Object
file = txtB.Text & ".txt"
If txtB.Value = "" Then MsgBox "What we calling it?", vbQuestion: Exit Sub
' Defines the range. So, from B2, across and down.
LastRow = Sheets("Pricing").Range("B" & Rows.Count).End(xlUp).Row
LastColumn = Sheets("Pricing").Cells(2, Columns.Count).End(xlToLeft).Column
'File details.
path = "C:\Users\me.me\Blah\Blah\"
MyFileName = path & file
Delimeter = "|"
' The magic bit.
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(MyFileName, False, True) '<==== This defines the Unicode bit.
For Row = 2 To LastRow
For Column = 2 To LastColumn
If Column = 2 Then Record = Trim(Cells(Row, Column)) Else Record = Record & Delimeter & Trim(Cells(Row, Column))
Next Column
MyFile.WriteLine (Record)
Next Row
MyFile.Close
MsgBox "BOOM! ---> " & MyFileName
'Option to open the finished product.
If ActiveSheet.CheckBox2.Value = True Then
Set shApp = CreateObject("shell.application")
shApp.Open (MyFileName)
End If
End Sub
I'm renaming files in VBA using the following code
Sub Dateien_umbenennen()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
xDir = oFSO.GetFolder(ThisWorkbook.Sheets("Sheet1").Range("F4").Value)
xFile = Dir(xDir & "\" & "*")
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 Sub
Old name in column A, new name in column B, folder specified by the value in cell F4. Some files in column A contain the ~ special character. Those files are not being renamed while the ones that don't have the character are. How can I rename the files that contain the ~ ?
I think that issue in xRow = Application.Match(xFile, Range("A:A"), 0). If you locate the row with, for example, name~1.txt, its need next syntax: xRow = Application.Match("name~~1.txt", Range("A:A"), e.g. double ~. Try this code: xRow = Application.Match(Replace(xFile,"~","~~"), Range("A:A"),0)
I am trying to make my code better, as every beginner I have problem to make it more "systematic", I would like your advice on how to do it.
I open few workbook, so now my macro looks like this.
Sub OpenWorkbooks()
workbooks.Open Filename :="C/.../file1.xlsx"
workbooks.Open Filename :="C/.../file2.xlsx"
workbooks.Open Filename :="C/.../file3.xlsx"
.
.
End sub
Its quite ugly, I would like to have each path in a cell. Let say from A1 to A3 and to loop this cell to open the workbooks. Any idea how I could do this?
In an other part of my code, nicely found on the web, I have the same problem. I would like to be able to enter my paths somewhere in my spreadsheet and then to loop it from there instead of entering manually one by one...
This is the second part of the code, quite clueless how I should do this...
Sub GetNumber()
Dim wWbPath As String, WbName As String
Dim WsName As String, CellRef As String
Dim Ret As String
Workbooks("file1").Close SaveChanges:=True
wbPath = "C:/etc...."
WbName = "file1.xlsx"
WsName = "Sheet1"
CellRef = "AD30"
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
Worksheets("Sheet1").Range("A1") = ExecuteExcel4Macro(arg)
'Then I need to do all again for the second workbook etc....
End sub
Any idea is welcome,
Thank you!
To answer the first part of your question:
Sub OpenWorkbooks()
For i = 1 to 3 ' Loop 3 times
Workbooks.Open Filename:=Sheet1.cells(i,1).value
'Cells refers to Row and column, so i will iterate three times while keeping the column the same.
Next i
End sub
If you don't know how many loops you will want to make, you could use the following to check the Last Row with data and loop until you reach it:
Sub OpenWorkbooks()
LastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 to LastRow ' Loop as many times until the last row with data
Workbooks.Open Filename:=Sheet1.cells(i,1).value
'Cells refers to Row and column, so i will iterate three times while keeping the column the same.
Next i
End sub
For the second part of your code you could do something like:
Sub GetNumber()
Dim wWbPath As String, WbName As String
Dim WsName As String, CellRef As String
Dim Ret As String
For i = 1 to 5 'Change this to however many files you will be using
FileName = Sheet1.cells(i,1).value
Workbooks(FileName).Close SaveChanges:=True
wbPath = "C:/etc...."
WbName = FileName & ".xlsx"
WsName = "Sheet1"
CellRef = "AD30"
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
Worksheets("Sheet1").Range("A" & i) = ExecuteExcel4Macro(arg)
'Then I need to do all again for the second workbook etc....
Next i
End sub
I had to figure out how do something similar recently. Try this ...
Dim i As Long
Dim SelectedFiles As Variant
SelectedFiles = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", _
Title:="Select files", MultiSelect:=True)
If IsArray(SelectedFiles) Then
For i = LBound(SelectedFiles) To UBound(SelectedFiles)
Set wbkToOpen = Workbooks.Open(Filename:=SelectedFiles(i), corruptload:=xlRepairFile)
Debug.Print wbkToOpen.Name
Debug.Print SelectedFiles(i)
wbkToOpen.Close savechanges:=False
Next
End If
I am trying to create a backup copy with VBA. The problem is, that everything except the row height is being copied. I tried looking for an answer, but couldnt find anything that fits.
Here's my code:
Application.Workbooks.Add ' Neue Mappe erstellen
Dim counter As Integer
Dim wbNew As Workbook
Dim shtOld, shtNew As Worksheet
Dim pfad As String
Dim name As String
pfad = ThisWorkbook.Path
name = Left(ThisWorkbook.name, Len(ThisWorkbook.name) - 5)
'MsgBox "Aktueller Pfad: " & ThisWorkbook.Path
'MsgBox Left(ThisWorkbook.name, Len(ThisWorkbook.name) - 5)
Set wbNew = Application.Workbooks(Application.Workbooks.Count)
Do While wbNew.Worksheets.Count < ThisWorkbook.Worksheets.Count
wbNew.Worksheets.Add ' Weitere Tabellen hinzufügen, falls nötig
Loop
' Tabellen kopieren
For counter = 1 To ThisWorkbook.Worksheets.Count
Set shtOld = ThisWorkbook.Worksheets(counter) ' Quelltabelle
Set shtNew = wbNew.Worksheets(counter) ' Zieltabelle
shtNew.name = shtOld.name ' Tabellenname übernehmen
shtOld.UsedRange.Copy ' Quelldaten und -format kopieren
shtNew.Range("A1").PasteSpecial Paste:=8 ' Spaltenbreite übernehmen
shtNew.UsedRange.PasteSpecial xlPasteValues ' Werte einfügen
shtNew.UsedRange.PasteSpecial xlPasteFormats ' Format übernehmen
Next
wbNew.SaveAs pfad & "\" & name & " " & Format(Now, "YYYYMMDD hhmm") & ".xlsx"
Application.CutCopyMode = False ' Zwischenspeicher löschen
'
Anyone got an idea? Would be great!
You want to assign the height, rather than copy/paste formatting. The code below should get you started:
Sub RowHeight()
Dim wsOne As Worksheet: Set wsOne = ActiveWorkbook.Sheets("Sheet1")
Dim wsTwo As Worksheet: Set wsTwo = ActiveWorkbook.Sheets("Sheet2")
Dim RowHght As Long
RowHght = wsOne.Range("A1").EntireRow.Height
wsTwo.Range("A1:A10").RowHeight = RowHght
End Sub
If I understand correctly then you are trying to save thisWorkBook with a new name as a backup. This code should do it a little more efficiently.
Sub saveCopyOfThisWorkBookWithNewName()
Dim fileFrmt As Long, oldFileName As String, newFileName As String
fileFrmt = ActiveWorkbook.FileFormat
oldFileName = ThisWorkbook.FullName
newFileName = Left(oldFileName, InStrRev(oldFileName, ".") - 1) & "_" & CStr(Format(Now, "YYYYMMDD hhmm"))
ThisWorkbook.SaveCopyAs Filename:=newFileName & ".xlsx"
End Sub
You need to select, copy and paste the rows to get the row heights to paste across
So on my "sheet1" I have data in columns A, B, C, D, E, F
I would like VBA code to combine the 1st (A), 3rd(C) and 5th (E) column and save it to a comma separated text file.
I have:
Option Explicit
Public Sub ExcelRowsToCSV()
Dim iPtr As Integer
Dim sFileName As String
Dim intFH As Integer
Dim aRange As Range
Dim iLastColumn As Integer
Dim oCell As Range
Dim iRec As Long
Dim lenth As String
Set aRange = Range("A1:C11")
iLastColumn = aRange.Column + aRange.Columns.Count - 1
iPtr = InStrRev(ActiveWorkbook.FullName, ".")
sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".txt"
sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="TXT (Comma delimited) (*.txt), *.txt")
If sFileName = "False" Then Exit Sub
Close
intFH = FreeFile()
Open sFileName For Output As intFH
iRec = 0
For Each oCell In aRange
If oCell.Column = iLastColumn Then
Print #intFH, oCell.Value
iRec = iRec + 1
Else
Print #intFH, oCell.Value; ",";
iRec = iRec + 1
End If
Next oCell
Close intFH
MsgBox "Finished: " & CStr(iRec) & " records written to " _
& sFileName & Space(10), vbOKOnly + vbInformation
End Sub
This works but only if the range declared has columns that lay right next to each other.
The fastest way is to copy the worksheet as a new workbook and then delete unnecessary columns and then save the file as csv. This will not affect the original file as well.
For example (TRIED AND TESTED)
Option Explicit
Sub Sample()
Dim wb As Workbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Copy the sheet as a new workbook
ws.Copy
ActiveSheet.Range("D:D,B:B,F:F").Delete Shift:=xlToLeft
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:\Sample.Csv", FileFormat:=xlCSV
ActiveWorkbook.Close (False)
Application.DisplayAlerts = True
End Sub
try changing your for each to this: (untested, but hope you get the idea)
dim str as string
For i= 1 to arange.rows
str=""
for j=1 to arange.columns
str=str & ","
next
Print #intFH, str
Next