I am using this code for my work but I got a problem, when I replace number it doesn't copy format. For example: In Excel 999.999 when replace in Word 999999. Could someone help me solving this ?
Sub test22()
Dim num_of_row As Long
Dim num_of_column As Long
Dim i As Long, j As Long
Dim template As Object
Dim t As Object
Dim name As String
num_of_column = 20
num_of_row = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row - 1
With CreateObject("word.application") ' late binding
.Visible = False
For i = 1 To num_of_row
Set template = .documents.Open("D:\zzz LINH TINH\02. Test VBA\01. LRAMP\Template_KHQLMT.docx")
Set t = template.Content
For j = 1 To num_of_column
t.Find.Execute _
FindText:=ActiveSheet.Cells(1, j).Value, _
ReplaceWith:=ActiveSheet.Cells(i + 1, j).Value, _
Replace:=wdReplaceAll
Next
template.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & i & "-KHQLMT " & ".docx"
Next
.Quit
End With
Set t = Nothing
Set template = Nothing
End Sub
Related
How can I change the separator that a CSV file is exported with in VBA without changing regional settings etc?
The macro should be used across multiple computers and different users, I don't want to confuse people with changing global settings on their computers.
Is there any way to use another separator?
This is my current code, but the values are separated with commas, I want semicolons
Sub ExportToCSV()
'Variables--------------------------------------------------------------
Dim CSVFileName As String
Dim sheet As Integer
Dim WsData As Worksheet
Set WsData = Worksheets("Database")
'-----------------------------------------------------------------------
WsData.Range(WsData.Cells(7, 9), WsData.Cells(7, 2).End(xlDown)).Copy
Application.DisplayAlerts = False 'avoid "save prompt window"
' Disable screen updating to improve performance
Application.ScreenUpdating = False
Workbooks.Add
ActiveSheet.Paste
' Convert the first row to lowercase
For Each cell In Range("A1:H1")
cell.Value = LCase(cell.Value)
Next cell
CSVFileName = ThisWorkbook.Path & "\" & "Database_" & VBA.Format(VBA.Now, "dd-mm-yy") & ".csv"
ActiveSheet.SaveAs Filename:=CSVFileName, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
' Enable screen updating again
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Note: there could be commas inside the data it is copying.
Any help is greatly appreciated, thank you.
Option Explicit
Sub exportcsv()
Const SHT_NAME = "Database"
Const HDR = 7
Const DELIM = ";"
Dim wb As Workbook, ws As Worksheet, arData
Dim oFSO As Object, oFS As Object
Dim c As Long, i As Long, n As Long, iLastrow As Long
Dim CSVFilename As String, s As String, quote As String
Dim t0 As Single: t0 = Timer
' create text file
Set wb = ThisWorkbook
CSVFilename = wb.Path & "\" & "Database_" & VBA.Format(VBA.Now, "dd-mm-yy") & ".csv"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.CreateTextFile(CSVFilename, True, True) 'overwrite, Unicode
' write out lines
Set ws = wb.Sheets(SHT_NAME)
With ws
iLastrow = .Cells(Rows.count, "B").End(xlUp).Row
' copy to array
arData = .Range("B1:I1").Offset(HDR - 1).Resize(iLastrow - HDR + 1) ' col 2-9
For i = 1 To UBound(arData)
s = ""
For c = 1 To UBound(arData, 2)
' header
If i = 1 Then arData(i, c) = LCase(arData(i, c))
' add quotes if special chr in value
If arData(i, c) Like "*[;""]*" Then
quote = Chr(34) ' "
Else
quote = ""
End If
' change " to ""
arData(i, c) = Replace(arData(i, c), Chr(34), Chr(34) & Chr(34))
If c > 1 Then s = s & DELIM
s = s & quote & arData(i, c) & quote
Next
oFS.writeline s
n = n + 1
Next
End With
oFS.Close
MsgBox n & " lines written to " & CSVFilename, _
vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
So I managed to create a code to copy and paste listbox values to a newly created excel file.
The thing is, I have it all concatenated and separated by a comma. It works fine but because of how it is exported, then I have to use Excel text to columns functionality to put the data like I want.
Here's the code:
Private Sub button_Export_AMAT_Click()
Dim i As Integer
Dim n As Integer
Dim strLine As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("\\yvavm301\Commun\CF_GDC\base de dados a trabalhar\AM_AT.csv", True)
For i = 0 To Me.List_AM_AT.ListCount - 1
For n = 0 To Me.List_AM_AT.ColumnCount - 1
strLine = strLine & """" & Me.List_AM_AT.Column(n, i) & ""","
Next n
strLine = Left(strLine, Len(strLine) - 1)
a.writeline (strLine)
strLine = ""
Next i
MsgBox "Your file is exported"
End Sub
My question is: is it possible to export a like for like table, ie. having the same number of columns and having them populated with right values?
The change has to be made here (see below), right?
strLine = strLine & """" & Me.List_AM_AT.Column(n, i) & ""","
a.writeline (strLine)
I've tried without luck the following:
strLine = Me.List_AM_AT.Column(n, i)
a.cells(i,n).writeline (strLine)
Does anyone have an idea of what to do?
As said in my comment you could create an Excel file in your code and write the values to that file. Right now you create a text file with your code which leads to the issues you describe in your post (text assistant etc.)
Private Sub button_Export_AMAT_Click()
Dim i As Integer
Dim n As Integer
' You might need to add a reference to Excel if your host application is Access
' Extra/Reference and select Microsoft Excel Object Library
Dim xl As Excel.Application
Set xl = New Excel.Application
Dim wkb As Workbook
Set wkb = xl.Workbooks.Add
Dim wks As Worksheet
Set wks = wkb.Sheets(1)
'Dim strLine As String
'Set fs = CreateObject("Scripting.FileSystemObject")
'Set a = fs.CreateTextFile("\\yvavm301\Commun\CF_GDC\base de dados a trabalhar\AM_AT.csv", True)
For i = 0 To Me.List_AM_AT.ListCount - 1
For n = 0 To Me.List_AM_AT.ColumnCount - 1
wks.Cells(i + 1, n + 1).Value = Me.List_AM_AT.Column(n, i)
'strLine = strLine & """" & Me.List_AM_AT.Column(n, i) & ""","
Next n
'
' strLine = Left(strLine, Len(strLine) - 1)
' a.writeline (strLine)
' strLine = ""
Next i
wkb.SaveAs "D:\TMP\EXPORT.XLSX" ' Adjust accordingly
wkb.Close False
xl.Quit
MsgBox "Your file is exported"
End Sub
I have a script that exports specific range of cell from Excel to Word. Below you can see the script
Sub Export_to_Word_Mac()
Dim filename As String
Dim FolderName As String
Dim Folderstring As String
Dim FilePathName As String
Dim sh As Worksheet
Dim print_area As Range
Dim appWD As Object
Dim wddoc As Object
Dim rng As Range
Dim paragraphCount As Long
Set sh = ThisWorkbook.Sheets("Sheet1")
sh.Unprotect
sh.Rows("15:16").EntireRow.Hidden = True
For Each rng In sh.Range("B17:B26")
If rng.Value Like "wpisz zakres usług tutaj..." Then
rng.EntireRow.Hidden = True
Else
rng.EntireRow.Hidden = False
End If
Next rng
sh.Protect
FolderName = "Export"
filename = sh.Range("G4") & "_test_" & Format(Now, "dd-mm-yyyy_hhmm") & ".docx"
Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
FilePathName = Folderstring & Application.PathSeparator & filename
On Error Resume Next
Set appWD = GetObject(, "Word.application")
If Err = 429 Then
Set appWD = CreateObject("Word.application")
Err.Clear
End If
Set wddoc = appWD.Documents.Add
appWD.Visible = True
With appWD.ActiveDocument.PageSetup
.TopMargin = appWD.InchesToPoints(0.5)
.BottomMargin = appWD.InchesToPoints(0.5)
.LeftMargin = appWD.InchesToPoints(0.5)
.RightMargin = appWD.InchesToPoints(0.5)
End With
'copy range to word
Set print_area = sh.Range("B1:C27")
print_area.Copy
'paste range to Word table
paragraphCount = wddoc.Content.Paragraphs.Count
wddoc.Paragraphs(paragraphCount).Range.Paste
Application.CutCopyMode = False
appWD.ActiveDocument.Tables(1).Rows.Alignment = wdAlignRowCenter
appWD.ActiveDocument.Cells.VerticalAlignment = wdCellAlignVerticalTop
'appWD.Activate
appWD.ActiveDocument.SaveAs (FilePathName)
MsgBox "Plik zostal zapisany jako: " & vbNewLine & filename & vbNewLine & _
" w nowo stworzonym " & FolderName & " w folderze: " & vbNewLine & "Library/Group Containers/UBF8T346G9.Office/"
appWD.Quit
Set wddoc = Nothing
Set appWD = Nothing
End Sub
Function CreateFolderinMacOffice2016(NameFolder As String) As String
Dim OfficeFolder As String
Dim PathToFolder As String
Dim TestStr As String
OfficeFolder = MacScript("return POSIX path of (path to desktop folder) as string")
OfficeFolder = Replace(OfficeFolder, "/Desktop", "") & _
"Library/Group Containers/UBF8T346G9.Office/"
PathToFolder = OfficeFolder & NameFolder
On Error Resume Next
TestStr = Dir(PathToFolder & "*", vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then
MkDir PathToFolder
'MsgBox "You find the new folder in this location :" & PathToFolder
End If
CreateFolderinMacOffice2016 = PathToFolder
End Function
Unfortunetely, there are a couple of issues:
It takes 1,5-2 minutes to export and save the Word file. Could you please help me to optimize the code?
I need to open Word application on my Mac to run the script. Otherwise I get Run-time error '9' (Script out of Range). The issue is with this line: Set appWD = GetObject(, "Word.application") .
The only solution I came up with is to use .CopyPicture xlScreen and paste it to Word document. I takes arpund 5 second create Word file, however the content is not editable and it is saved as image.
Option 1: Keep using Copy but optimize VBA execution
There are many options to improve speed execution in Excel VBA (see this articles for more details), but the most useful when copy-pasting is certainly to set :
Application.ScreenUpdating = False
However, since you are pasting in Word, you'd have to do the same this for the Word Application to get the maximum speed improvement:
appWD.ScreenUpdating = False
Note: Make sure to reset Application.ScreenUpdating = True at the end of your code.
Option 2 : Use an array to transfer the data
If the formatting of the cell in Excel is not necessary, then you could load the content of the cells into an array and write this array to the word document like this:
'copy range to word
Dim DataArray() As Variant
DataArray = sh.Range("B1:C27").Value
Dim i As Integer, j As Integer
Dim MyWordRange As Object
Set MyRange = appWD.ActiveDocument.Range(0, 0)
appWD.ActiveDocument.Tables.Add Range:=MyRange, NumRows:=UBound(DataArray, 1), NumColumns:=UBound(DataArray, 2)
'paste range to Word table
For i = 1 To UBound(DataArray, 1)
For j = 1 To UBound(DataArray, 2)
appWD.ActiveDocument.Tables(1).Cell(i, j).Range.Text = DataArray(i, j)
Next j
Next i
Note that option 1 and 2 are not necessarily mutually exclusives.
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
The following code opens selected files, one at a time; if a file contains specific text string in B11 (there are four variation: LS2A, LS1PRA, LS1A and LSM12), specified data from Sheet(1) of each file is copied into an array. The search is performed by function “SearchFor” that is called in the main routine.
The array ArrCopy is filled with data from each file and should output into one of the four sheets in Master Workbook(SABI, SABII,LSM or LPRI&II). The output sheet is determined by the text string in B11 of each file.
I can’t get data to output to Master workbook for some reason. I've tried Debug.Print each array item after it's filled and I can see that the array is filled with correct data but I can't get the values to tranfer to the master workbook. The code runs but nothing is outputed on the worksheet.
Please suggest how to make this work. Thanks
Option Explicit
Function SearchFor(output As Worksheet)
Dim rowsCount As Long
Dim NCBead1 As Long, NCBead2 As Long, PCBead1 As Long, PCBead2 As Long
Dim IniString As String, IniVar As String
Dim rngCell As Range, rngCell2 As Range
Dim ArrCopy(1 To 9) As Variant
Dim LastRow As Long
Dim aCell As Range
LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
'extract initial after last underscore
IniString = ActiveWorkbook.Sheets(1).Range("B6").Value
IniVar = Right(IniString, Len(IniString) - InStrRev(IniString, "_", , 1))
Debug.Print IniVar
'Debug.Print "LastRow = " & LastRow
Set aCell = ActiveSheet.Range("B1:B" & LastRow).Find(What:="Trimmed Mean", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'Debug.Print "Trimmed Mean can be found in Row # " & aCell.Row
'wb.Sheets(1).Select
For Each rngCell In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow)
If InStr(rngCell, "NC") > 0 Then
Debug.Print rngCell.Row
NCBead1 = rngCell.Offset(0, 1).Value
NCBead2 = rngCell.Offset(0, 2).Value
'End If
Exit For
End If
Next rngCell
For Each rngCell2 In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow)
If InStr(rngCell2, "PC") > 0 Then
Debug.Print rngCell2.Row
PCBead1 = rngCell2.Offset(0, 1).Value
PCBead2 = rngCell2.Offset(0, 2).Value
'End If
Exit For
End If
Next rngCell2
'Next searched
Debug.Print NCBead2
ArrCopy(1) = ActiveSheet.Range("B3").Value
ArrCopy(2) = IniVar
ArrCopy(3) = NCBead1
ArrCopy(4) = NCBead2
ArrCopy(5) = PCBead1
ArrCopy(6) = PCBead2
ArrCopy(7) = ActiveSheet.Range("B6").Value
ArrCopy(8) = NCBead1
ArrCopy(9) = NCBead1
' one row spanning several columns
Debug.Print "ArrCopy" & ArrCopy(1)
Debug.Print "ArrCopy" & ArrCopy(2)
Debug.Print "ArrCopy" & ArrCopy(3)
Dim Destination As Range
Set Destination = output.Range("A" & output.Range("A" & Rows.Count).End(xlUp).Row + 1)
Set Destination = Destination.Resize(1, UBound(ArrCopy))
Destination.Value = ArrCopy
End Function
Sub openselectedfiles()
Dim SaveDriveDir As String, MyPath As String, FnameInLoop As String
Dim mybook As Workbook, thisWb As Workbook
Dim N As Long, LstUnderSc As Long, ExtPer As Long, Varin As Long
Dim Fname As Variant, ArrCopy(1 To 9) As Variant
Dim output As Worksheet
Dim inLS2A As Boolean, inLS1PRA As Boolean, inLS1A As Boolean, inLSM12 As Boolean
Set thisWb = ThisWorkbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="CSV Files (*.csv),*.csv", _
Title:="Select a file or files", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
If Not mybook Is Nothing Then
mybook.Sheets(1).Select
With ActiveSheet.Range("B11")
inLS2A = InStr(1, .Value, "LS2A", 1) > 0
inLS1PRA = InStr(1, .Value, "LS1PRA", 1) > 0
inLS1A = InStr(1, .Value, "LS1A", 1) > 0
inLSM12 = InStr(1, .Value, "LSM12", 1) > 0
End With
If inLS2A Then
Set output = thisWb.Sheets("SABII")
SearchFor output
ElseIf inLS1PRA Then
Set output = thisWb.Sheets("LPRI&II")
SearchFor output
ElseIf inLS1A Then
Set output = thisWb.Sheets("sabI")
SearchFor output
ElseIf inLSM12 Then
Set output = thisWb.Sheets("LSM")
SearchFor output
End If
'End If
mybook.Close SaveChanges:=False
Set mybook = Nothing
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function