Essentially I am trying use VBA to copy data from Excel and paste values in a new notepad file. I was able to create a successful macro using sendkeys, but am trying to avoid this I know it is not the most reliable. I have tried using createobject to create and write to temp files but no luck. I am getting a "permission denied" error. Once the Notepad file is generated, I do not want to save it down, just leave it open for the user to review the data and they can save as they need. Any suggestions on alternatives? Code I have been trying is below.
Application.ScreenUpdating = False
Dim formulasheet As Worksheet
Dim copysheet As Worksheet
Dim num As Integer
Dim valuecolumn As Range, cell As Object
Dim copycolumn As Range
Dim i As Range
Dim strTempFile As String
Dim strData As String
num = 0
Set formulasheet = ActiveWorkbook.Sheets("Template")
Set copysheet = ActiveWorkbook.Sheets("Copy")
Set valuecolumn = formulasheet.Range("B:B")
Set copycolumn = formulasheet.Range("A:A")
formulasheet.Visible = xlSheetVisible
copysheet.Visible = xlSheetVisible
copysheet.Cells.Clear
formulasheet.Select
For Each i In valuecolumn
If i.Value > 0 Then
i.Offset(0, -1).Copy
copysheet.Select
copysheet.Range("A1").End(xlUp).Offset(num, 0).PasteSpecial Paste:=xlPasteValues
num = num + 1
End If
Next i
copysheet.Cells.WrapText = False
If copysheet.Range("A1") = "" Then
MsgBox "No transaction amounts, please review."
copysheet.Visible = xlSheetHidden
formulasheet.Visible = xlSheetHidden
Exit Sub
Else
copysheet.Select
strData = copysheet.Range("A:A").SpecialCells(xlCellTypeConstants).Copy
strTempFile = "C:\temp.txt"
With CreateObject("Scripting.FileSystemObject")
.CreateTextFile(strTempFile, False).Write strData
End With
Shell "cmd /c ""notepad.exe """ & strTempFile & """", vbHide
End If
SendKeys "{NUMLOCK}", True
copysheet.Visible = xlSheetHidden
formulasheet.Visible = xlSheetHidden
Related
I am currently using a piece of code to loop through files in a folder and copy certain cells from each file into a master list. There are a number of files being added into the folder every week. One of the columns in the master list includes the filenames of previously looped files. The code only loops through files that are not included in the filename list and therefore also have not previously been looped.
The code works really well and copies cells with satisfactory results however I now need to modify it to also copy a range of data (A20:H33 specifically) as well as meeting the above condition of not already being looped.
I have tried the following unsuccesfully:
Adding another varTemp to the code (As seen in the main code)
Adding a sub that can copy a range (However I have been unable to incorporate this into the code so it satisfies the not looped condition)
Using selection.copy and selection.paste however an error that I cannot workaround pops up ("Object doesn't support this property or method")
Here is the main code:
Option Explicit
Sub CopyFromFolderExample()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strFolder As String, strFile As String, r As Long, wb As Workbook
Dim varTemp(1 To 6) As Variant
Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
strFile = Dir(strFolder & "*.xl*")
Do While Len(strFile) > 0
If Not Looped(strFile, ws) Then
Application.StatusBar = "Reading data from " & strFile & "..."
Set wb = Workbooks.Add(strFolder & strFile)
With wb.Worksheets(1)
varTemp(1) = strFile
varTemp(2) = .Range("A13").Value
varTemp(3) = .Range("H8").Value
varTemp(4) = .Range("H9").Value
varTemp(5) = .Range("H37").Value
'varTemp(6) = .Range("A20:H33").Value
End With
wb.Close False
r = r + 1
ws.Range(ws.Cells(r, 1), ws.Cells(r, 6)).Formula = varTemp
End If
strFile = Dir
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Private Function Looped(strFile As String, ws As Worksheet) As Boolean
Dim Found As Range
Set Found = ws.Range("A:A").Find(strFile)
If Found Is Nothing Then
Looped = False
Else
Looped = True
End If
End Function
This is the snippet of code that when inserted into the main code just below tha last vartemp gives me the following error ("Object doesn't support this property or method")
.Range("A20:H33").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ws.Activate
If ws.Range("A1") = "" Then
ws.Range("A1").Select
Selection.Paste
Else
Selection.End(xlDown).Offset(6, 0).Select
Selection.Paste
End If
Here is what I am trying to achieve:
I think that if you use a Range variable instead of a Variant to copy and paste the Range(A20:AH33) should get the job done.
Declare:
Dim rg as Range
Then replace this line of code:
varTemp(6) = .Range("A20:H33").Value
For this:
Set rg = .Range("A20:H33")
Then you can just Rg.Copy and paste whereaver you want.
Don't forget to "clear" the copybuffer after you paste the information:
Application.CutCopyMode = False
Avoid to use Selectionand Activate in your code, the reasons for it can be seen here:
How to avoid using Select in Excel VBA
and here:
https://www.businessprogrammer.com/power-excel-vba-secret-avoid-using-select/
This should do it. I've turned your array back to 5 elements, and the range is transferred separately. I've added a few new variables which you might want to give more meaningful names.
Sub CopyFromFolderExample()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strFolder As String, strFile As String, r As Long, wb As Workbook
Dim varTemp(1 To 5) As Variant, r1 As Long, r3 As Range
Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"
strFile = Dir(strFolder & "*.xl*")
Do While Len(strFile) > 0
If Not Looped(strFile, ws) Then
Application.StatusBar = "Reading data from " & strFile & "..."
Set wb = Workbooks.Add(strFolder & strFile)
With wb.Worksheets(1)
varTemp(1) = strFile
varTemp(2) = .Range("A13").Value
varTemp(3) = .Range("H8").Value
varTemp(4) = .Range("H9").Value
varTemp(5) = .Range("H37").Value
Set r3 = .Range("A20:H33")
End With
With ws
r = .Range("A" & .Rows.Count).End(xlUp).Row + 1
r1 = .Range("F" & .Rows.Count).End(xlUp).Row + 1 'last used row in col F
.Range(.Cells(r, 1), .Cells(r, 5)).Value = varTemp
.Cells(r1, 6).Resize(r3.Rows.Count, r3.Columns.Count).Value = r3.Value 'transfer A20:H33
End With
wb.Close False
End If
strFile = Dir
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
I have about 100 Word documents and from each I want to copy data and paste it all in one Excel workbook.
I came up with this code which opens one Word document, copies data, pastes it to Excel and closes the Word document:
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
Dim wrdDoc As Object
Documents.Open ("D:\ekr5_i.doc")
TgtFile = "result.xlsx"
Tgt = "D:\" & TgtFile
'finds the text string of Lgth lenght
txt = "thetext"
Lgth = 85
Strt = Len(txt)
'Return data to array
With Selection
.HomeKey unit:=wdStory
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.Workbooks.Open(Tgt)
Set mySh = myWB.Sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.Transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub
I need to loop through all the documents in the folder.
I have implemented the same with Excel workbooks, but I don't know how for Word documents.
Here is the code for Excel workbooks:
Sub combine_into_one()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPath$, Pivot$, sUserName$, sFolderName$, sSourceName$, x&
Dim oFldialog As FileDialog
Dim oFolder
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set oFldialog = Application.FileDialog(msoFileDialogFolderPicker)
With oFldialog
If .Show = -1 Then
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
sFolderName = .SelectedItems(1)
End If
End With
Set oFolder = FSO.GetFolder(sFolderName)
Workbooks.Add: Pivot = ActiveWorkbook.Name 'Destination workbook
For Each oFile In oFolder.Files
Workbooks(Pivot).Activate
x = Workbooks(Pivot).Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks.Open Filename:=oFile: sSourceName = ActiveWorkbook.Name
Workbooks(sSourceName).Activate
Workbooks(sSourceName).Sheets(1).[A80:Q94].copy
Workbooks(Pivot).Activate
Workbooks(Pivot).Sheets(1).Cells(x + 1, 1).PasteSpecial xlPasteAll
Workbooks(sSourceName).Close False
Next
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There are so, so, so many things you can do between Excel & Word. I'm not sure I totally understand your question. The script below may help you; it has definitely served me well over time. If you need something different, please describe your issue more, to better clarify the issue you are facing.
Sub OpenAndReadWordDoc()
Rows("2:1000000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
' assumes that the previous procedure has been executed
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim blnStart As Boolean
Dim r As Long
Dim sFolder As String
Dim strFilePattern As String
Dim strFileName As String
Dim sFileName As String
Dim ws As Worksheet
Dim c As Long
Dim n As Long
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err Then
Set oWordApp = CreateObject("Word.Application")
' We started Word for this macro
blnStart = True
End If
On Error GoTo ErrHandler
Set ws = ActiveSheet
r = 1 ' startrow for the copied text from the Word document
' Last column
n = ws.Range("A1").End(xlToRight).Column
sFolder = "C:\Users\Excel\Desktop\Coding\Microsoft Excel\PWC\Resumes\"
'~~> This is the extension you want to go in for
strFilePattern = "*.doc*"
'~~> Loop through the folder to get the word files
strFileName = Dir(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'~~> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
' Increase row number
r = r + 1
' Enter file name in column A
ws.Cells(r, 1).Value = sFileName
ActiveCell.Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("A" & r), Address:=sFileName, _
SubAddress:="A" & r, TextToDisplay:=sFileName
' Loop through the columns
For c = 2 To n
If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
MatchWholeWord:=True, MatchCase:=False) Then
' If text found, enter Yes in column number c
ws.Cells(r, c).Value = "Yes"
End If
Next c
oWordDoc.Close SaveChanges:=False
'~~> Find next file
strFileName = Dir
Loop
ExitHandler:
On Error Resume Next
' close the Word application
Set oWordDoc = Nothing
If blnStart Then
' We started Word, so we close it
oWordApp.Quit
End If
Set oWordApp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Function GetDirectory(path)
GetDirectory = Left(path, InStrRev(path, "\"))
End Function
In this scenario, whatever you put in the headers of B1:K1 (or more to the right) is searched for, each word document in a folder is opened, scanned, and if the string in B1:K1 is found, an 'x' is placed in the same x-y coordinate.
Again, if this doesn't help, please describe your issue better, and I'll post back with alternative solutions. Thanks!!
So I want to automate a lot of manual work of copy/paste with the help of a Macro. The macro should read all files from folder one by one, copy the content from that source file range "I9:J172" and paste it on the destination file (where the macro is of course) on the column first blank row.
Application.ScreenUpdating = False
'For Each Item In franquicia
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open("C:\folder\inventory.xlsb", True, True)
' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
Dim iTotalRows As Integer
iTotalRows = src.Worksheets("INV").Range("I9:J" & Cells(Rows.Count, "J").End(xlUp).Row).Rows.Count
' FIND FIRST BLANK CELL
Dim LastRow As Long
LastRow = Worksheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' COPY DATA FROM SOURCE (CLOSE WORKGROUP) TO THE DESTINATION WORKBOOK.
Dim iCnt As Integer ' COUNTER.
For iCnt = 1 To iTotalRows
Worksheets("Hoja1").Range("A" & LastRow & ":B" & iCnt).Value = src.Worksheets("INV").Range("I9:J172" & iCnt).Value
Next iCnt
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
'Next Item
I want to solve first this last row problem and then do an array and the loop to read all the files one by one.
Thank you!
The following code does what you've described, and the animated gif demonstrates with 3 test files (with test data in the columns you mentioned). The first part of the gif shows the contents of 2 of the test files, and then runs the macro, stepping through it, showing the result on a "combined" sheet. Click on the gif to see better detail. Note that each test file's data must be on a "data" sheet. You can modify, of course.
Option Explicit
Dim theDir As String, alreadyThere As Boolean, wk As Workbook
Dim sh As Worksheet, comboSh As Worksheet, comboR As Range
Dim r As Range, s As String, numFiles As Integer
Const ext = ".xlsx"
Sub CombineFiles()
Set comboSh = getSheet(ThisWorkbook, "Combined", True)
theDir = ThisWorkbook.Path
s = Dir(theDir & "\*" & ext)
Set comboR = comboSh.Range("A1")
While s <> ""
ThisWorkbook.Activate
If comboR <> "" Then Set comboR = comboR.Offset(0, 2)
comboR.Activate
Set wk = Workbooks.Open(theDir & "\" & s)
Set sh = getSheet(wk, "data", False)
Set r = sh.Range("I9:J72")
'Set r = sh.Range(r, r.End(xlToRight))
'Set r = sh.Range(r, r.End(xlDown))
r.Copy
comboSh.Paste
Application.DisplayAlerts = False
wk.Close False
Application.DisplayAlerts = True
s = Dir()
numFiles = numFiles + 1
Wend
MsgBox ("done")
End Sub
Function getSheet(wk As Workbook, shName As String, makeIfAbsent As Boolean) As Worksheet
alreadyThere = False
For Each sh In wk.Worksheets
If sh.Name = shName Then
alreadyThere = True
Set getSheet = sh
End If
Next
If Not alreadyThere Then
If makeIfAbsent Then
Set getSheet = wk.Sheets.Add
getSheet.Name = shName
Else
MsgBox shName & " sheet not found -- ending"
End
End If
End If
End Function
I may be arriving to the party too late. It seems like you got the solution you were after. For future reference, try the AddIn below. This will do all kinds of copy/paste/merge tasks.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
I'm not experienced with VBA, but I think it's the only way for this to work.
I need to send a report to each sales team, but don't want to send them the information of other sales team. There are multiple sheets per workbook with different reports which all have a sales team column.
I would like all the sheets to be filtered by sales team, and create a new workbook for each team.
I appreciate any help.
I got this solution.
Just send me an email if you need this solution.
At first I got this format:
I create the following macro code
Option Explicit
Dim MainWorkBook As Workbook
Dim NewWorkBook As Workbook
Sub ExportWorksheet()
Dim Pointer As Long
Set MainWorkBook = ActiveWorkbook
Range("E2").Value = MainWorkBook.Sheets.Count
Application.ScreenUpdating = False 'enhance the performance
For Pointer = 2 To MainWorkBook.Sheets.Count
Set NewWorkBook = Workbooks.Add
MainWorkBook.Sheets(Pointer).Copy After:=NewWorkBook.Sheets(1)
Application.DisplayAlerts = False
NewWorkBook.Sheets(1).Delete
Application.DisplayAlerts = True
With NewWorkBook
.SaveAs Filename:="C:\Users\lengkgan\Desktop\Testing\" & MainWorkBook.Sheets(Pointer).Name & ".xls" 'you may change to yours
End With
NewWorkBook.Close SaveChanges:=True
Next Pointer
Application.ScreenUpdating = True
Range("D5").Value = "Export Completed"
End Sub
Following is the output
I have written a VBA(Macro) program which will work based on Input data. All you need to do is, provide input data in a column in another sheet. Macro will read the data and filter Master Sheet based on each row then it Generate new excel sheet based on find data.
enter Option Explicit
Dim personRows As Range 'Stores all of the rows found
'Split data into separate columns baed on the names defined in
'a RepList on the 'Names' sheet.
Sub SplitSalesData()
Dim wb As Workbook
Dim p As Range
Dim counter2 As Integer
Dim i As Integer
counter2 = 0
i = 0
Application.ScreenUpdating = False
' in my case i am generating new excel based on every 8 reacords from begining. You can simplyfy this logic based on your need.
For Each p In Sheets("Names").Range("RepList") ' Give the name of your input sheet and column
If i = 0 Then ' We are starting, so generate new excel in memeory.
Workbooks.Add
Set wb = ActiveWorkbook
ThisWorkbook.Activate
End If
WritePersonToWorkbook wb, p.Value
i = i + 1 ' Increment the counter reach time
If i = 8 Then ' As my need is after processing every 8 uniqe record just save the excel sheet and reset the processing
counter2 = counter2 + 1
wb.SaveAs ThisWorkbook.Path & "\salesdata_" & CStr(counter2) ' save the data at current directory location.
wb.Close
Set personRows = Nothing ' Once the process has completed for curent excelsheet, set the personRows as NULL
i = 0
End If
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
'Writes all the data rows belonging to a RepList
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
ByVal Person As String)
Dim rw As Range
Dim firstRW As Range
For Each rw In UsedRange.Rows
If Not Not firstRW Is Nothing And Not IsNull(rw) Then
Set firstRW = rw ' WE want to add first row in each excel sheet.
End If
If Person = rw.Cells(1, 5) Then ' My filter is working based on "FeederID"
If personRows Is Nothing Then
Set personRows = firstRW
Set personRows = Union(personRows, rw)
Else
Set personRows = Union(personRows, rw)
End If
End If
Next rw
personRows.Copy SalesWB.Sheets(1).Cells(1, 1) ' Adding data in Excel sheet.
End Sub
please find below code
Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim icol As Long
Dim l As Long
Dim headercol As Long
Dim stroutputfolder As String
stroutputfolder = "D:\Ba"
'dim str
icol = 1
headercol = 3
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
For nRow = headercol + 1 To nLastRow
'Get the specific Column
'Here my instance is "B" column
'You can change it to your case
strColumnValue = objWorksheet.Cells(nRow, icol).Value
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
Next
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
'MsgBox (varColumnValues(i))
If Dir(stroutputfolder, vbDirectory) = vbNullString Then MkDir stroutputfolder
If CStr(varColumnValue) <> "" Then
objWorksheet.UsedRange.Offset(headercol - 1, 0).AutoFilter Field:=icol, Criteria1:=CStr(varColumnValue)
Set objExcelWorkbook = Excel.Application.Workbooks.Add
Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name
objWorksheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
'strFilename = strOutputFolder & "\" & strItem
ActiveWorkbook.SaveAs Filename:=stroutputfolder & "\" & CStr(varColumnValue) & ".xlsb", FileFormat:=50
ActiveWorkbook.Close savechanges:=False
l = l + 1
End If
Next
objWorksheet.ShowAllData
MsgBox (l & " files splitted")
End Sub
I wrote this Access/VBA program. It works but only when I am not running other applications or few users are in the database. I need some ideas on streamlining the code. So it is not so system intensive. The program basically allows a user to pick a folder and then combines all worksheets in that folder in one excel document. My current idea is just to tell users to close all excel files when trying to run the program. Please Help:
Sub Excel_open()
Dim myXL As Excel.Application
Dim myXLS As Excel.Workbook
Const errExcelNotRunning = 429
On Error GoTo HandleIt
Set myXL = GetObject(, "Excel.application")
myXL.Visible = True
Set myXLS = myXL.Workbooks.Add
Call CombineWorkbooks(myXL)
HandleIt:
If Err.Number = errExcelNotRunning Then
Set myXL = CreateObject("Excel.Application")
Err.Clear
Resume Next
End If
End Sub
Sub CombineWorkbooks(myXL)
'Macro that combines the files into one folder
myXL.AskToUpdateLinks = False
myXL.DisplayAlerts = False
Dim CurFile As String, dirloc As String, strNamesheet As String
Dim DestWB As Workbook
Dim ws As Object ' allows for diffrent sheet types
'Add select the director function
dirloc = GetFolderName & "\" 'location of files not working want to select the file only
CurFile = Dir(dirloc & "*.xls*")
myXL.ScreenUpdating = False
myXL.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(FileName:=dirloc & CurFile, ReadOnly:=True)
'need to change a name active name is not doing it
CurFile = Left(CurFile, 4) ' This is no longer 29
'CurFile = Left(Left(CurFile, Len(CurFile) - 5), 29)
For Each ws In OrigWB.Sheets
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
' Use the name to give the sheet a name
strNamesheet = Left((ws.Name), 25) & ";"
If OrigWB.Sheets.Count > 1 Then
DestWB.Sheets(DestWB.Sheets.Count).Name = strNamesheet & CurFile ' & ws.Index
Else
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile
End If
Next
OrigWB.Close SaveChanges:=False
CurFile = Dir
Loop
myXL.DisplayAlerts = False
DestWB.Sheets(1).Delete
myXL.DisplayAlerts = True
myXL.ScreenUpdating = True
myXL.EnableEvents = True
Set DestWB = Nothing
Call Delete_empty_Sheets(myXL)
Call Sort_Active_Book
MsgBox "Done"
'Call Xcombine_the_Matching
End Sub
Sub Delete_empty_Sheets(myXL)
'goes through all sheets and deletes
Reset_the_search:
For Each wsElement In Worksheets
If wsElement.Range("A2") = "" And wsElement.Range("B2") = "" Then
myXL.DisplayAlerts = False
wsElement.Delete
GoTo Reset_the_search
myXL.DisplayAlerts = True
End If
Next wsElement
End Sub
Sub Xcombine_the_Matching()
'I think I can make the order work
'change and transpose the array
Dim varStart As Variant
Dim wsCompare As Worksheet
Dim strMatch As String
'Dim varCompare As Variant
Dim strVareince As String
Dim strCurrentName As String
'you need to build a loop to solve this problem
For Each wsCompare In Worksheets
strVareince = Add_Array(Application.Transpose(wsCompare.Range("A1:Z1")))
For Each wsNompare In Worksheets
If wsNompare.Name <> strCurrentName Then
If strVareince = Add_Array(Application.Transpose(wsNompare.Range("A1:Z1"))) Then
MsgBox ("Matched with worksheet " & wsNompare.Name)
End If
End If
Next
Next
End Sub
Function array_to_string(x) As String
For Z = 1 To 26
array_to_string = array_to_string & x(Z, 1) & ";"
Next Z
End Function
Function GetFolderName(Optional OpenAt As String) As String
'Allows you to select the folder director that you want to combine
Dim lCount As Long
GetFolderName = vbNullString
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = OpenAt
.Show
For lCount = 1 To .SelectedItems.Count
GetFolderName = .SelectedItems(lCount)
Next lCount
End With
End Function
Function Add_Array(x) As String
'turns an excel document
For d = 1 To UBound(x)
Add_Array = Add_Array & x(d, 1)
Next d
End Function
Sub Read_data()
'this the
End Sub
Sub Sort_Active_Book()
Dim i As Integer
Dim j As Integer
Dim iAnswer As VbMsgBoxResult
'
' Prompt the user as which direction they wish to
' sort the worksheets.
'
iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
& "Clicking No will sort in Descending Order", _
vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
For i = 1 To Sheets.Count
For j = 1 To Sheets.Count - 1
'
' If the answer is Yes, then sort in ascending order.
'
If iAnswer = vbYes Then
If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
'
' If the answer is No, then sort in descending order.
'
ElseIf iAnswer = vbNo Then
If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
End If
Next j
Next i
End Sub
You are passing your Excel Application object into your subroutines, but not using it fully, neither are you explicitly referencing the libraries:
Sub CombineWorkbooks(myXL)
Dim DestWB As Excel.Workbook ' <<<
Set DestWB = myXL.Workbooks.Add(xlWorksheet) ' <<<
End Sub
Run through your code and fix all of these first, then test & supply more feedback on what the precise symptoms of the problems are.