VBA: Excel stops working after extracting data from other workbooks - excel

I'm trying to extract data from other 4 workbooks (some of them may have thousands of rows)
The Excel stops working, and restarts, after the extraction is completed.
I have the data extracted in the sheets so I assume that the excel is chrashing after the last workbook data is extracted.
I also tested with only one workbook and it crashes after closing.
I have read that we could use "DoEvents" and "Application.Wait" after copy/paste or close workbook, to let Excel finish some background work. I've tried that but with no success.
Any ideas why the Excel stops running / restarts?
Here is my code:
Public sysExtractParamsDictionary As Scripting.dictionary
'Sub rotine triggered when pressing button
Sub Extract()
Set sysExtractParamsDictionary = mUtils.FillDictionary("sysParams", "tExtractParams") 'Sub rotine belonging to mUtils module to fill dictionary with values from my sysParams sheet. Contains the sheets name.
mClean.Clean 'Sub rotine belonging to mClean module to clear sheets
ExtractData [sysInputDirectory], "Input Sheet" 'Cell Name sysInputDirectory
ExtractData [sysR2Directory], "R1 Sheet"
ExtractData [sysR2Directory], "R2 Sheet"
ExtractData [sysR3Directory], "R3 Sheet"
End Sub
Sub ExtractData(sFilePath As String, sDictionaryKey As String)
Dim oWorkbook As cWorkBook 'Class Module
Set oWorkbook = New cWorkBook
mUtils.SetStatusBarMessage True, "Extracting " & sDictionaryKey & " ..." 'Sub rotine belonging to my mUtils module to set on or off status bar message
oWorkbook.WorkBookDirectory = sFilePath
oWorkbook.OpenWorkBook oWorkbook.WorkBookDirectory
oWorkbook.CopiesSourceSheetValuesToDestinationSheet sysExtractParamsDictionary(sDictionaryKey)
oWorkbook.CloseWorkBook (False)
DoEvents
DoEvents
Application.Wait (Now + TimeValue("0:00:05"))
DoEvents
Set oWorkbook = Nothing
End Sub
'#### Class Module
Private wbWorkBook As Workbook
Private sWorkBookDirectory As String
Private sWorkBookName As String
Private wsWorksheet As Worksheet
Public Property Set Workbook(wbNew As Workbook)
Set wbWorkBook = wbNew
End Property
Public Property Get Workbook() As Workbook
Set Workbook = wbWorkBook
End Property
Public Property Let WorkBookDirectory(sFilePath As String)
sWorkBookDirectory = sFilePath
End Property
Public Property Get WorkBookDirectory() As String
WorkBookDirectory = sWorkBookDirectory
End Property
Public Property Let WorkBookName(sFileName As String)
sWorkBookName = sFileName
End Property
Public Property Get WorkBookName() As String
WorkBookName = sWorkBookName
End Property
Public Property Set Worksheet(wsNew As Worksheet)
Set wsWorksheet = wsNew
End Property
Public Property Get Worksheet() As Worksheet
Worksheet = wsWorksheet
End Property
Public Property Let WorkBookDirectory(sFilePath As String)
sWorkBookDirectory = sFilePath
End Property
Public Property Get WorkBookDirectory() As String
WorkBookDirectory = sWorkBookDirectory
End Property
'Class Module Function to Open WorkBook
Public Sub OpenWorkBook(sFilePath As String)
Dim oFSO As New FileSystemObject
Dim sFileName As String
Dim sLog As String
sFileName = oFSO.GetFileName(sFilePath) 'Get the File Name from Path
If sFileName = "" Then
sLog = "Error. Not possible to retrieve File Name from Directory."
Else
Me.WorkBookName = sFileName
Set Me.Workbook = Workbooks.Open(sFilePath)
If wbWorkBook Is Nothing Then
sLog = "Error opening file: " & Me.WorkBookName
Else
sLog = "File successfully openned!"
End If
End If
Set oFSO = Nothing
End Sub
'Class Module Function to Copy Values from source to destination
Public Sub CopiesSourceSheetValuesToDestinationSheet(wsDestinationName As Variant)
Dim wsDestination As Worksheet
Dim rStartRange As range
Dim rFullRangeToPaste As range
Set wsDestination = ThisWorkbook.Sheets(CStr(wsDestinationName)) ' Destination Sheet
Set Me.Worksheet = Me.Workbook.Sheets(1) 'Source Sheet
Set rStartRange = wsWorksheet.range("A1")
Set rFullRangeToPaste = wsWorksheet.range(rStartRange, mUtils.FindLast(3)) 'FindLast is a function belonging to mUtils module to find the last cell in worksheet
rFullRangeToPaste.Copy wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp)
End Sub
'Class Module Function to Close Workbook
Public Sub CloseWorkBook(bSaveChanges As Boolean)
wbWorkBook.Saved = True
wbWorkBook.Close SaveChanges:=False
End Sub
'#### End Class Module
I've also tried to do it without Class Module (just in case something was wrong with objects), but i still have the same issue.
Sub Extract()
ExtractCopyClose "C:\MyFiles\InputData.csv", "Input"
End Sub
Sub ExtractCopyClose(sFilePath As String, wsDestinationName As String)
Dim wb As New Workbook
Dim wsDestination As Worksheet
Dim wsSource As Worksheet
Dim oFSO As New FileSystemObject
Dim sLog As String
Dim rStartRange As range
Dim rFullRangeToPaste As range
sFileName = oFSO.GetFileName(sFilePath) 'Get the File Name from Path
If sFileName = "" Then
sLog = "Error. Not possible to retrieve File Name from Directory."
Else
Set wb = Workbooks.Open(sFilePath)
If wb Is Nothing Then
sLog = "Error opening file: " & sWorkBookName
Else
sLog = "File successfully openned!"
End If
End If
Set oFSO = Nothing
Set wsDestination = ThisWorkbook.Sheets(wsDestinationName) ' Destination Sheet
Set wsSource = wb.Sheets(1) 'Source Sheet
Set rStartRange = wsSource.range("A1")
Set rFullRangeToPaste = wsSource.range(rStartRange, mUtils.FindLast(3))
rFullRangeToPaste.Copy wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp)
wb.Saved = True
wb.Close SaveChanges:=False
End Sub

I have found that the sheet I was importing from the other workbook had external connections and was creating Connections and new References in my Workbook. Don't know why, but somehow this was affecting my Excel and causing it to restart since I was copying all the sheet content.
Instead of copying the full source sheet to my workbook...
rFullRangeToPaste.Copy wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp)
I copied only the values and formats of the source sheet...
Dim rDestinationRange As Range
'the rest of the code in question
rFullRangeToPaste.Copy wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp)
Set rDestinationRange = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp)
rFullRangeToPaste.Copy
wsDestination.PasteSpecial xlPasteValuesAndNumberFormats
Note: This worked after my workbook recovered from the previous extraction (without broken external connections and null references). Then I made the changes in the code and save it.

Related

How to open a workbooks with the path file?

I am struggling with Workbooks(). In the below code I want the user to pick the file and get the path file from the dialogbox. All these steps are working. However I am struggling the use pathKeys. It seems when I write Workbooks(pathkeys) I have an error 9 (Script our of range).
Sub getData()
Dim diagBoxkeys As FileDialog
Dim pathKeys As String
Set diagBoxkeys = Application.FileDialog(msoFileDialogFilePicker)
diagBoxkeys.Title = "Keys File " & FileType
diagBoxkeys.Filters.Clear
diagBoxkeys.Show
If diagBoxkeys.SelectedItems.Count = 1 Then
pathKeys = diagBoxkeys.SelectedItems(1)
End If
MsgBox (pathKeys)
Dim wbKeys As Workbook
ScreenUpdating = False
Set wbKeys = GetObject(pathKeys)
Workbooks(pathKeys).Worksheets(1).Columns(2).Copy Destination:=Workbooks("Macro_PORTAL_APRR.xlsm").Worksheets(1).Columns(1)
wbKeys.Close Savechanges:=False
End Sub
However when in this code I replace Workbooks(pathKeys) with Workbooks("Keys_2021-12-27_13_43_21_utf-8.csv") it works perfectly.
I don't understand why pathKeys is not accepted as pathKeys = C:\Users\tn5809\Documents\PROJETS\PORTAL_APRR\Keys_2021-12-27_13_43_21_utf-8.csv
What am I doing wrong ?
This might work better for you.
'This should appear at the top of all modules.
'It forces you to declare all variables.
'Tools ~ Options ~ Require Variable Declaration.
Option Explicit
Public Sub GetData()
'*** If Macro_Portal is not file containing this code: ***
Dim MacroPortalPath As String
MacroPortalPath = OpenFile ' or MacroPortalPath = "C:\...\...\Macro_PORTAL_APRR.xlsm"
Dim MacroPortal As Workbook
MacroPortal = Workbooks.Open(MacroPortalPath)
'*** If Macro Portal is the file containing this code: ***
'Dim MacroPortal As Workbook
'Set MacroPortal = ThisWorkbook
Dim pathKeys As String
pathKeys = OpenFile
If pathKeys <> "" Then
Dim wrkBk As Workbook
Set wrkBk = Workbooks.Open(pathKeys)
'Best to use sheet name rather than where it is in workbook (can be moved by user).
'You could replace MacroPortal with ThisWorkbook and remove first block of code in this procedure.
wrkBk.Worksheets("Sheet1").columns2.Copy Destination:=MacroPortal.Worksheets("Sheet1").Column(1)
wrkBk.Close SaveChanges:=False
End If
End Sub
Public Function OpenFile() As String
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogFilePicker)
With dialogBox
.Title = "Keys File"
.AllowMultiSelect = False
.InitialFileName = "C:\"
If .Show = -1 Then
OpenFile = .SelectedItems(1)
End If
End With
End Function

Adding new and removing old VBA to all workbooks in a folder

I have about 60 workbooks with several modules and I need to remove one sub routine in one module then add code to a specific worksheet.
I currently have code running every time you open the workbook asking to run and archive data to another worksheet, it works. Problem is we are in the workbooks several times, so every time we open them, we have to answer the question.
I found a more elegant way to ask to archive when I go to the first worksheet where we go to change data at the end of the month. Only when we open this are we needing to archive the old data. Some times we go here to look at the data, but it's not the usual. I have new code now for the specific worksheet using on select, that works.
I'm trying to update the code across all my workbooks without having to open them up 1 by 1 and make the changes, copy, paste, delete, save, open next file, repeat.
'code to remove from module named ArchiveHistoricalData
Sub Auto_Open()
AskArchive
End Sub
'Code to add to worksheet named Data Dump
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
AskArchive
End Sub
I'd like to remove the first sub, then add the second sub to a specific worksheet (Named the same across all workbooks). Then if I have changes in the future, I can easily update all my workbooks with other changes.
Posting another answer structured as generalized tools to delete and/or add or replace any number of procedures from any number of files. As mentioned earlier it is assumed that Trust Access to Visual Basics Project must be enabled.
In a new excel file with added reference to Microsoft Visual Basic for Application extensibility, add a module named “Copy_Module”. Specifically in your case, copy Worksheet_SelectionChange code in a module named “Copy_Module”.
Its AddReplaceProc function would copy any procedure from a module named “Copy_Module” in the source workbook while DeleteProc function would delete a procedure.
Sub test4()
Dim Wb As Workbook, ws As Worksheet
Dim Path As String, Fname As String
Dim Fno As Long
Path = "C:\Users\User\Documents\TestFolder\"
Fname = Dir(Path & "*.xlsm")
Fno = 1
Do While Fname <> ""
Set Wb = Application.Workbooks.Open(Path & Fname)
If Wb.VBProject.Protection = vbext_pp_none Then
Set ws = ThisWorkbook.ActiveSheet
Fno = Fno + 1
ws.Cells(Fno, 1).Value = Fname
'ws.Cells(Fno, 2).Value = AddReplaceProc(Wb, "ArchiveHistoricalData", "DoStuff2")
ws.Cells(Fno, 2).Value = DeleteProc(Wb, "ArchiveHistoricalData", "Auto_Open")
ws.Cells(Fno, 3).Value = AddReplaceProc(Wb, Wb.Worksheets("Data Dump").CodeName, "Worksheet_SelectionChange")
Wb.Close True
Else
Wb.Close False
End If
Fname = Dir
Loop
End Sub
Private Function DeleteProc(Wb As Workbook, CompName As String, ProcName As String) As Boolean
Dim Vbc As CodeModule, Vbcomp As VBComponent
DeleteProc = False
For Each Vbcomp In Wb.VBProject.VBComponents
If Vbcomp.Name = CompName Then
Set Vbc = Vbcomp.CodeModule
On Error GoTo XExit
If Vbc.ProcStartLine(ProcName, 0) > 0 Then
Vbc.DeleteLines Vbc.ProcStartLine(ProcName, 0), Vbc.ProcCountLines(ProcName, 0)
DeleteProc = True
Exit For
End If
End If
Next Vbcomp
XExit: On Error GoTo 0
End Function
Private Function AddReplaceProc(Wb As Workbook, CompName As String, ProcName As String) As Boolean
Dim Vbc As CodeModule, Vbcomp As VBComponent
Dim VbcSrc As CodeModule, StLine As Long, EndLine As Long
Dim i As Long, X As Long
'Check for older version of the procedure and delete the same before coping new version
AddReplaceProc = DeleteProc(Wb, CompName, ProcName)
Debug.Print "Old Proc " & ProcName & " Found and Deleted : " & AddReplaceProc
AddReplaceProc = False
For Each Vbcomp In Wb.VBProject.VBComponents
If Vbcomp.Name = CompName Then
Set Vbc = Vbcomp.CodeModule
Set VbcSrc = ThisWorkbook.VBProject.VBComponents("Copy_Module").CodeModule
StLine = VbcSrc.ProcStartLine(ProcName, 0)
EndLine = StLine + VbcSrc.ProcCountLines(ProcName, 0) - 1
X = 0
For i = StLine To EndLine
X = X + 1
Vbc.InsertLines X, VbcSrc.Lines(i, 1)
Next i
AddReplaceProc = True
Exit For
End If
Next Vbcomp
End Function
Proper caution is a must for this type of remote changes. It is always wise to try the code first only to copies of target files and confirm proper working etc.
It only works with files with unprotected VBA projects. For files with protected VBA files refer SO post Unprotect VBProject from VB code.
Try the code from any workbook (not in the same target folder) module. Add reference to Microsoft visual basic for applications extensibility. and/or make vbext_pk_Proc as 0.
Sub test3()
Dim ws As Workbook
Dim Vbc As CodeModule
Dim Path As String, Fname As String
Dim Wx As Worksheet
Dim HaveAll As Boolean
Dim VbComp As VBComponent
Path = "C:\Users\User\Documents\TestFolder\"
Fname = Dir(Path & "*.xlsm")
Do While Fname <> ""
' Debug.Print Fname
Set ws = Application.Workbooks.Open(Path & Fname)
HaveAll = False
For Each VbComp In ws.VBProject.VBComponents
If VbComp.Name = "ArchiveHistoricalData" Then
'used erron handler instead of iterating through all the lines for keeping code short
On Error GoTo failex
If VbComp.CodeModule.ProcStartLine("Auto_Open", 0) > 0 Then
HaveAll = True
failex: Resume failex2
failex2: On Error GoTo 0
Exit For
End If
End If
Next VbComp
If HaveAll Then
HaveAll = False
For Each Wx In ws.Worksheets
If Wx.Name = "Data Dump" Then
HaveAll = True
Exit For
End If
Next Wx
End If
If HaveAll Then
Set Vbc = ws.VBProject.VBComponents("ArchiveHistoricalData").CodeModule
Vbc.DeleteLines Vbc.ProcStartLine("Auto_Open", vbext_pk_Proc), Vbc.ProcCountLines("Auto_Open", vbext_pk_Proc)
Set Vbc = ws.VBProject.VBComponents(ws.Worksheets("Data Dump").CodeName).CodeModule
Vbc.InsertLines 1, "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
Vbc.InsertLines 2, "AskArchive"
Vbc.InsertLines 3, "End Sub"
ws.Close True
Else
ws.Close False
End If
Debug.Print Fname, HaveAll
Fname = Dir
Loop
End Sub
However code will encounter error if the stated Worksheets, code modules and procedures are not available. Please take due care, if not confirmed about availability of the stated Worksheets, code modules and procedures in all the target files. (may use error handler or check for existence for the Sheets, code modules and procedures by iterating through after opening the target file and skip accordingly). Also Trust Access To Visual Basics Project must be enabled.

VBA module call in userform to diff sheets

new and would like to ask if someone could possibly check my code to see where i'm making a mistake.
first, i've created a form with two textboxes and two buttons that will go and get two different directories and the associated files. this is done through a call to a function that loads the dir to the textboxes.
a button to call a function to navigate dir and get the file
Private Sub CommandButton3_Click()
'call selectFile function to select file
selectFile
End Sub
function to get workbooks into textboxes 1 and 2:
Public Function selectFile()
Dim fileNamePath1 As String
Dim fileNamePath2 As String
Dim workbookFilePath1 As String
Dim workbookFilePath2 As String
On Error GoTo exit_
If workbookFilePath1 = Empty And workbookFilePath2 = Empty Then
fileNamePath1 = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open Workbook 1", MultiSelect:=False)
workbookFilePath1 = Dir(fileNamePath1)
'TextBox1.Text = workbookFilePath1
TextBox1.Value = fileNamePath1
fileNamePath2 = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open Workbook 2", MultiSelect:=False)
workbookFilePath2 = Dir(fileNamePath2)
TextBox2.Value = fileNamePath2
If fileNamePath1 = False Or fileNamePath2 = False Then
MsgBox ("File selection was canceled.")
Exit Function
End If
End If
exit_:
End Function
up to here, the code is ok... can do better, but
here's where problems occur... i'd like to pass the directories as objects into the module to diff
button that executes module to diff:
Private Sub CommandButton1_Click()
getTheWorkbooksToCompare(fileNamePath1, fileNamePath2)
End Sub
i know that i've changed myPath1 and myPath2 to Workbooks, where I've had them as strings before
diffing module
Public Sub gettheWorkbooksToCompare(myPath1 As Workbook, myPath2 As Workbook)
Dim myExcelObj
Dim WorkbookObj1
Dim WorkbookObj2
Dim WorksheetObj1
Dim WorksheetObj2
Dim file1 As String
Dim file2 As String
Dim myWorksheetCounter As Integer
Dim i As Worksheet
Set myExcelObj = CreateObject("Excel.Application")
myExcelObj.Visible = True
Set file1 = Dir(myPath1)
Set file2 = Dir(myPath2)
Set WorkbookObj1 = myExcelObj.Workbooks.Open(file1)
Set WorkbookObj2 = myExcelObj.Workbooks.Open(file2)
Set NewWorkbook = myExcelObj.Workbooks.Add
While WorkbookObj1 <> Null And WorkbookObj2 <> Null
'While WorkbookObj1.ActiveWorkbook.Worksheets.count = WorkbookOjb2.ActiveWorkbook.Worksheets.count
myWorksheetCounter = ActiveWorkbook.Worksheets.count
myWorksheetCount = ActiveWorkbook.Worksheets.count
If WorksheetObj1.Worksheets.myWorksheetCounter = WorkbookObj2.Worksheets.myWorksheetCounter Then
Set WorksheetObj1 = WorkbookObj1.Worksheets(myWorksheetCounter)
Set WorksheetObj2 = WorkbookObj2.Worksheets(myWorksheetCounter)
Set myNewWorksheetObj = NewWorkbook.Worksheets(myWorksheetCounter)
For myWorksheetCounter = i To WorksheetObj1
For myWorksheetCount = j To WorksheetOjb2
'If cell.Value myWorksheetObj2.Range(cell.Address).Value Then
If cell.Value = myWorksheetObj2.Range(cell.address).Value Then
myNewWorksheetObj.Range(cell.address).Value = cell.address.Value
myNewWorksheetObj.Range(cell.address).Interior.ColorIndex = 3
Else
cell.Interior.ColorIndex = 0
End If
Next
'if doesn't work... use SaveChanges = True
myNewWorksheetObj.Workbooks.Save() = True
Next
Else
MsgBox ("The worksheets are not the same worksheets." & vbNewLine & "Please try again.")
End If
Wend
Set myExcelObj = Nothing
End Sub
So my question is... can someone please assist in seeing where i'm going wrong? essentially, i'm having some issues in trying to get this working.
much appreciated
i've gone through and cleaned up some areas a little bit... but now have a: "run time error '438': object doesn't support this propety or method" at the while loop code that i've updated the post with
I see a typo on CommandButton1_Click
Private Sub CommandButton1_Click()
getTheWorkbooksToCompare(fileNamePath1, fileNamePath2)
End Sub
Public Sub gettheWorkbooksToCompare(myPath1 As Workbook, myPath2 As Workbook)
There might be something more, but your not capitalizing the "T" in getThe, but you call it that way.

Call excel function in access vba

I've a sub in excel that needs to be called from access.
Excel vba
Public Function testme(value As String) As String
Dim xlpath As String
Dim concate As String
xlpath=ActiveWorkbook.Path
value = ActiveWorkbook.Name
concate = xlpath & "\" & value
Let testme = concate
End Function
i need to call above method in one of the access method.How do i call it.
Sub Connect1()
Dim xlApp As Variant
'Set xlApp = CreateObject("Excel.Application")
'this will launch a blank copy of excel; you'll have to load workbooks
'xlApp.Visible = True
Set xlApp = GetObject(, "Excel.Application")
Let ans = xlApp.Application.Run("MyXLVBAProject.MyXLVBAModule.testme", 400)
'here ans has the string "500"
End Sub
You'll probably want to use Application.Run from Excel's object model. You pass it a string such as "QuickRDA.JavaCallBacks.GetQuickTab" for the macro name, where QuickRDA is the name of the Excel VBA project, JavaCallBacks is the name of the VBA module in that VBA project, and GetQuickTab is the name of the function in that VBA module.
In Access
Sub Connect()
Dim xlApp As Variant
Set xlApp = GetObject(, "Excel.Application")
'this will connect to an already open copy of excel, a bit easier for quick & dirty testing
Let ans = xlApp.Application.Run("MyXLVBAProject.MyXLVBAModule.testme")
End Sub
In Excel
Public Function testme() As String
Dim xlpath As String
Dim concate As String
Dim value as String
xlpath = ActiveWorkbook.Path
value = ActiveWorkbook.Name
concate = xlpath & "\" & value
Let testme = concate
End Function
-or simply-
Public Function testme() As String
Let testme = ActiveWorkbook.FullName
End Function
Remember that in Excel the function testme should be put in a module whose name is MyXLVBAModule, and that the project containing the module should be called MyXLVBAProject.
So, you want to trigger an Excel function from Access, or run an Excel subroutine from Access?
To run a function, you can do something like this.
Public Function FV(dblRate As Double, intNper As Integer, _
dblPmt As Double, dblPv As Double, _
intType As Integer) As Double
Dim xl As Object
Set xl = CreateObject("Excel.Application")
FV = xl.WorksheetFunction.FV(dblRate, intNper, dblPmt, dblPv, intType)
Set xl = Nothing
End Function
To run an Excel subroutine from Access, you can do the following.
Sub RunExcelMacro()
Dim xl As Object
'Step 1: Start Excel, then open the target workbook.
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("C:\Book1.xlsm")
'Step 2: Make Excel visible
xl.Visible = True
'Step 3: Run the target macro
xl.Run "MyMacro"
'Step 4: Close and save the workbook, then close Excel
xl.ActiveWorkbook.Close (True)
xl.Quit
'Step 5: Memory Clean up.
Set xl = Nothing
End Sub

Copy used range to text file

I want to:
Copy the used range of a sheet called "Kommentar"
Create a ".txt" file ("Kommentar.txt") in the same directory as ThisWorkbook
Paste the previously copied used range
Save the ".txt" file
I have:
Sub CreateAfile()
Dim pth As String
pth = ThisWorkbook.path
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim a As Object
Set a = fs.CreateTextFile(pth & "\Kommentar.txt", True)
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Kommentar")
Dim rng As Range
Set rng = sh.UsedRange
a.WriteLine (rng)
a.Close
End Sub
I get
run-time error '13' Mismatch
In line a.WriteLine (rng) the function doesn't accept range to be written.
Since your range is probably made up of several cells, you have to loop through them to get all the text into a string variable. If you use a Variant variable you can copy the values and automatically get an array with the correct dimensions of all the data in the cells, then loop it and copy the text:
Function GetTextFromRangeText(ByVal poRange As Range) As String
Dim vRange As Variant
Dim sRet As String
Dim i As Integer
Dim j As Integer
If Not poRange Is Nothing Then
vRange = poRange
For i = LBound(vRange) To UBound(vRange)
For j = LBound(vRange, 2) To UBound(vRange, 2)
sRet = sRet & vRange(i, j)
Next j
sRet = sRet & vbCrLf
Next i
End If
GetTextFromRangeText = sRet
End Function
Call the function in your code by replacing the a.WriteLine (rng) line with the following:
Dim sRange As String
sRange = GetTextFromRangeText(rng)
Call a.WriteLine(sRange)
Not sure you can do that. I believe you would have to write it out line by line.
Here is an alternative option.
Rather than use the FSO, you could just try saving the sheet as a .txt file.
Here's some sample code.
Credit should goto http://goo.gl/mEHVx
Option Explicit
'Copy the contents of a worksheet, and save it as a new workbook as a .txt file
Sub Kommentar_Tab()
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wbDest As Workbook
Dim fName As String
'References
Set wbSource = ActiveWorkbook
Set wsSource = ThisWorkbook.Sheets("Kommentar")
Set wbDest = Workbooks.Add
'Copy range on original sheet
'Using usedrange can be risky and may return the wrong result.
wsSource.UsedRange.Copy
'Save in new workbook
wbDest.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
'Get file name and location
fName = ThisWorkbook.Path & "\Kommentar.txt"
'Save new tab delimited file
wbDest.SaveAs fName, xlText
wbDest.Close SaveChanges:=True
End Sub
Let's say yourRange is the range you want to copy as string.
Use yourRange. Copy to copy it.
After you copied it, Excel saves the text value to the clipboard. Cells in a row separated by tabs, and every row ends with an enter. You can use DataObject's GetFromClipboard and GetText method to save it to a string variable.
Use CreateTextFile to save it to a file.
#xwhitelight gives a good outline. Thanks. But I needed to supply details to myself to accomplish my own task and thought I'd share.
First, a Reference to Microsoft Scripting Runtime and another to Microsoft Forms 2.0 Object Library are required.
The coding details I added to produce an output file follow.
Note that textfilename is the fully-qualified name of the output file that contains the spreadsheet range.
Note that textfilename is opened in the last line of the sub, which isn't necessary, but it's reassuring to SEE what the file contains. Of course, the MsgBox is also unnecessary.
Sub turnRangeIntoTextFile(rg As Range, textfilename As String)
Dim textFile as TextStream
Dim fs As FileSystemObject
Dim myData As DataObject
Set myData = New DataObject
Set fs = CreateObject("Scripting.FileSystemObject")
rg.Copy
myData.GetFromClipboard
MsgBox myData.GetText ' reassurance (see what I got)
Set textFile = fs.CreateTextFile(textfilename, True)
textFile.WriteLine (myData.GetText)
textFile.Close
CreateObject("Shell.Application").Open (textfilename)
End Sub

Resources