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
Related
I'm a C# Programmer and new into Excel VBA and here I am on my limit.
I don't get the gist how to copy and paste data from different files into one Masterfile..
I want to collect all data from Excel Files in a userdefined folder. These data were always stored in excel files.
And always starts at the D column until last column from the 6th row to last row.
So I want first to get the Parent directory in which I get all the Files in this Parentfolder.
After that I start the CollectSubdataProcedure.
So my approach would be copy the range from each subfile and paste them into the 6th row and last column of my masterfile
Private Sub CollectData()
Dim MasterWorkbook As Workbook
Set MasterWorkbook = Workbooks("Masterfile.xlsm")
Dim Folderpath As String
'Get Folder which contains all Data
Folderpath = UserGetFolder & "\"
Dim obj As Object
Dim ParentFolder As Object
Dim Files As Object
Set obj = CreateObject("Scripting.FileSystemObject")
Set ParentFolder = obj.GetFolder(Folderpath)
Set Files = ParentFolder.Files
Application.ScreenUpdating = False
'Loop through all folder now
Dim subfile As Object
For Each subfile In ParentFolder.Files
'Start Data Collection
Call CollectSubdata(subfile)
Next subfile
End Sub
Here my Sub Procedure
Private Sub CollectSubdata(ByRef subfile As Object)
' Do Data collection here
Dim subwb As Workbook
Dim LastColumn As Double
Dim LastRow As Double
Dim LastMasterCol As Double
LastMasterCol = MasterWorkbook.Sheets(1).Cells(6, Columns.Count).End(xlToLeft).Column
Set subwb = Workbooks.Open(subfile)
LastColumn = subwb.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = subwb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
'Copy all necessary entries
subwb.Sheets(1).Range(Cells(6, 4), Cells(LastRow, LastColumn)).Copy
'Paste into Masterfile
MasterWorkbook.Sheets(1).Cells(6, LastMasterCol).PasteSpecial Paste:=xlPasteAll
subwb.Close
End Sub
And Here my Userdefined Folder
Function UserGetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
UserGetFolder = sItem
Set fldr = Nothing
End Function
I don't get the gist of VBA uses these objects and methods..
A variable only exists in the context in which it is defined. In your case the pointer masterworkbook is defined within the routine CollectData so it only exists within that routine. In order to get it into CollectSubData you either need to pass a reference to it as an argument to the subroutine, or define the variable at module level so that it exists for all routines within that module. The former is better practice, so you should define your CollectSubData as
Private Sub CollectSubdata(ByRef subfile As Object, ByRef MasterWorkbook As Workbook)
and call it as
'Start Data Collection
CollectSubdata(subfile,MasterWorkbook)
Note that Call is not needed in this context (although it's not wrong per se)
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.
SOLVED! See the code below for the solution!
I have an Excel file containing multiple shape objects next to a series of text. I wrote a script to identify the location of each shape, identify how many cells to the right and down the text extends to, sets that as a range and then imports that into a chart object so I can save it as a .jpg.
The trouble is that between the creation of the chart and the pasting of the string there exists a Race Condition. If I step through the script it works fine, but as soon as I run it I get nothing but blank images.
I've tried Application.ScreenUpdating = True; Application.PrintCommunication = True; and DoEvents
I've also tried Application.Wait, but even having it wait ten seconds doesn't do the trick, when stepping through the code the chart is loaded in less than 2 seconds.
Recently I tried the kernel32 sleep method as well, and that doesn't seem to work either. Again, the amount of time I let the system sleep far exceeded my stepping. I also added all of the above methods between each line within the With statement (obviously not as a solution, but as a test) and that didn't work either..
At this point I'm completely at a loss.
If I place a stop at .Chart.Paste and then run the script (F5), and just keep hitting Run then the script works wonderfully. I just don't want users to have to sit there and hit run 600 times.
There are obvious redundancies written in between the creation of the chart and pasting of the text. This is all in the attempt at getting the code to work properly when run, and once a solution is found most of that code will be removed.
Option Explicit
Public Function ChartCheck() As String
ReCheckChart:
DoEvents
If ActiveWorkbook.ActiveSheet.ChartObjects.Count > 0 Then
GoTo ContinuePaste:
Else
GoTo ReCheckChart:
ContinuePaste:
End If
End Function
Public Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder to Save the Images In"
.AllowMultiSelect = False
If .Show -1 Then GoTo NextCode:
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Private Sub DNImageExtraction_Click()
Dim fileName As String
Dim targetWorkbook As Excel.Workbook
Dim targetWorksheet As Excel.Worksheet
Dim saveLocation As Variant
Dim saveName As String
Dim targetShape As Shape
Dim workingRange As Excel.Range
Dim bottomRow As Long
Dim workingRangeWidth As Double
Dim workingRangeHeight As Double
Dim tempChart As ChartObject
Application.ScreenUpdating = False
Application.DisplayAlerts = False
DNImageExtraction.AutoSize = False 'This is necessary to prevent the system I use from altering the font on the button
DNImageExtraction.AutoSize = True
DNImageExtraction.Height = 38.4
DNImageExtraction.Left = 19.2
DNImageExtraction.Width = 133.8
fileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Please select Excel file...")
Set targetWorkbook = Workbooks.Open(fileName)
Set targetWorksheet = targetWorkbook.ActiveSheet
saveLocation = GetFolder
For Each targetShape In targetWorksheet.Shapes
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Offset(1, 0)
saveName = workingRange.Text
If workingRange.Offset(0, 1).Value "" Then
If workingRange.Offset(1, 1).Value = "" Then
Set workingRange = Nothing
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize(, 2)
Else
bottomRow = workingRange.Offset(0, 1).End(xlDown).Row
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize((bottomRow + 2 - workingRange.Row), 2)
End If
workingRangeWidth = workingRange.Width
workingRangeHeight = workingRange.Height
End If
workingRange.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Set tempChart = targetWorksheet.ChartObjects.Add(0, 0, workingRangeWidth, workingRangeHeight)
Application.ScreenUpdating = True
Application.PrintCommunication = True
DoEvents
Call ChartCheck
tempChart.Chart.Paste
Application.ScreenUpdating = False
tempChart.Chart.Export fileName:=saveLocation & "\DN " & saveName & ".jpg", Filtername:="JPG"
tempChart.Delete
Set tempChart = Nothing
Next
Application.Workbooks(targetWorkbook.Name).Close savechanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Any assistance in either a solution to the Race Condition, or re organizing the script to avoid the Race Condition altogether would be greatly appreciated.
(Code above was updated per suggestions made by Macro Man, and then re-modified once again to add in all previous suggestions on how to fix Race Condition issues after the changes were not effective.)
Consider using Application.OnTime which is good feature. It allows the scheduling of some code to be run at a certain time, most often one adds a few seconds to the current time.
Excel VBA is single-threaded and so there is no real synchronization but there is a message pump to keep order. The great thing about Application.OnTime is that it will not run despite being scheduled until the current graph of code has completed.
Because Application.OnTime uses the message pump as that is a FIFO structure it is possible to interleave the execution of code.
I think this might help here.
You can schedule a "hasItFinished" procedure which checks the existence of the shape/chart objects and if not re-schedules itself.
P.S. Can be a little tricky to debug, refactor as much code as possible outside of the procedure that you will schedule and unit test them separately. Please don't expect the lovely Edit,Debug and Continue flow that you normally get with VBA if you go down this path.
Try getting rid of the error handlers and labels, and working with objects directly instead of searching through workbook/worksheet collections. Also using meaningful variable names and proper indentation will help follow the code easily should you have any issues.
If your code works when stepping through, that usually suggests there is some issue with the use of ActiveWorkbook when workbooks are being opened/closed. Working with workbooks as objects allows us to overcome that problem because no matter if the workbook is active or not, we are always using the same instance of that workbook.
Private Sub DNImageExtraction_Click()
Dim fileName As String
Dim targetWorkbook As Excel.Workbook
Dim targetWorksheet As Excel.Worksheet
Dim saveLocation As Variant
Dim saveName As String
Dim targetShape As Shape
Dim workingRange As Excel.Range
Dim bottomRow As Long
Dim workingRangeWidth As Double
Dim workingRangeHeight As Double
Dim tempChart As ChartObject
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Please select Excel file...")
Set targetWorkbook = Workbooks.Open(fileName)
Set targetWorksheet = targetWorkbook.ActiveSheet
saveLocation = GetFolder
For Each targetShape In targetWorksheet.Shapes
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Offset(1, 0)
saveName = workingRange.Text
If workingRange.Offset(0, 1).value <> "" Then
If workingRange.Offset(1, 1).value = "" Then
Set workingRange = Nothing
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize(, 2)
Else
bottomRow = workingRange.Offset(0, 1).End(xlDown).Row
Set workingRange = targetWorksheet.Cells(targetShape.TopLeftCell.Row, targetShape.TopLeftCell.Column).Resize((bottomRow + 2 - workingRange.Row), 2)
End If
workingRangeWidth = workingRange.Width
workingRangeHeight = workingRange.Height
End If
workingRange.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Set tempChart = targetWorksheet.ChartObjects.Add(0, 0, workingRangeWidth, workingRangeHeight)
With tempChart
.Chart.Paste
.Chart.Export FileName:=saveLocation & "\DN " & saveName & ".jpg", Filtername:="JPG"
.Delete
End With
Set tmpChart = Nothing
DoEvents
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
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.
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.