I wrote a program in VB.net in visual studio and wanted to test if it still works, after installing windows 11
now I have the problem it always stops at the line Dim ws As Worksheet = wk2.Sheets(1) Does anyone know the problem?
Imports Microsoft.Office.Interop.Excel
Class MainWindow
Private Sub Button_Click(sender As Object, e As RoutedEventArgs)
Dim MyExcel As New Microsoft.Office.Interop.Excel.Application
MyExcel.Visible = True
Dim wk1, wk2 As Workbook
Dim path1, path2, path3 As String
path1
path2
path3
wk1 = MyExcel.Workbooks.Open(path1)
wk2 = MyExcel.Workbooks.Open(path2)
' Dim ws1 = wk1.Sheets(1)
'ws1.Range("F:F").Replace(("_*"), "")
wk1.Unprotect()
wk2.Unprotect()
Dim Row1 = wk1.Sheets(1).Cells(wk1.Sheets(1).Rows.Count, 1).End(-4162).Row
Dim Row2 = wk2.Sheets(1).Cells(wk2.Sheets(1).Rows.Count, 1).End(-4162).Row + 1
Dim Rng1 = MyExcel.Intersect(wk1.Sheets(1).UsedRange, wk1.Sheets(1).Range("2:" & Row1))
Dim Rng2 = wk2.Sheets(1).Range("A" & Row2).ReSize(Rng1.Rows.Count, Rng1.Columns.Count)
Rng2.Value = Rng1.Value
wk1.Close(SaveChanges:=False)
wk2.SaveAs(path3)
wk2.Close()
Dim ws As Worksheet = wk2.Sheets(1)
Dim StartDatum As String
Dim EndDatum As String
StartDatum = InputBox("Start-Datum:", "Eingabe", Format(Now, "YYYYMMDD"))
EndDatum = InputBox("End-Datum:", "Eingabe", Format(Now, "YYYYMMDD"))
ws.Range("D:D").Replace(("Startdatum im Format JJJJMMTT"), StartDatum)
ws.Range("E:E").Replace(("Enddatum im Format JJJJMMTT"), EndDatum)
ws.Range("A:AZ").Replace(("Keine Eintragung..."), "")
ws.Range("A:AZ").Replace(("Keine Ei"), "")
ws.Range("F:F").Replace(("_*"), "")
ws.Range("F:F").Replace(("-*"), "") ' Bei Änderung nochmal hier löschen und mit dem oberen auskommentierten ersetzen.
ws.Range("A:AZ").Replace(("Keine OP"), "")
ws.SaveAs()
End Sub
End Class
I tried it before and it worked. Now it doesn't work anymore.
Related
hi i'm trying to create a list of folders from an excel sheet and in each folder, it should be a txt file named let's say name.txt and in each of these files it should write wats in column b
pic1
I used this code to create the folders but I need help about creating the txt files
Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub
I need help generating the text file in each folder
Create Text Files From Worksheet Data
Sub MakeFolders()
Const fRow As Long = 2
Const SubFolderColumn As String = "A"
Const TextColumn As String = "B"
Const TextFileNameCellAddress As String = "B1"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim wbPath As String: wbPath = ws.Parent.Path & "\"
Dim TextFileName As String
TextFileName = CStr(ws.Range(TextFileNameCellAddress).Value)
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, SubFolderColumn).End(xlUp).Row
Dim srg As Range: Set srg = ws.Range(ws.Cells(fRow, SubFolderColumn), _
ws.Cells(lRow, SubFolderColumn))
Dim sCell As Range
Dim TextFile As Long
Dim FolderPath As String
Dim SubFolderName As String
Dim FilePath As String
Dim FileText As String
For Each sCell In srg.Cells
SubFolderName = CStr(sCell.Value)
If Len(SubFolderName) > 0 Then
FolderPath = wbPath & SubFolderName & "\"
If Len(Dir(FolderPath, vbDirectory)) = 0 Then
MkDir FolderPath
End If
FilePath = FolderPath & TextFileName
FileText = CStr(sCell.EntireRow.Columns(TextColumn).Value)
' Or (the same):
'FileText = CStr(ws.Cells(sCell.Row, TextColumn).Value)
TextFile = FreeFile
Open FilePath For Output As #TextFile
Print #TextFile, FileText
Close TextFile
End If
Next sCell
MsgBox "Files created.", vbInformation
End Sub
try to use FSO.CreateTextFile:
Sub Macro1()
'
' Macro1 Macro
'
'
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strPath As String
strPath = "d:\name.txt"
Dim oFile As Object
Set oFile = fso.CreateTextFile(strPath)
oFile.WriteLine "test"
oFile.Close
Set fso = Nothing
Set oFile = Nothing
End Sub
I am using a VBA sub which works inconsistently. The sub is based on a previous Stack Overflow thread answer I found which when it works is perfect. Copy Data from Excel to Notepad.
Sub CopyEventtoNotepad()
'Dim rngData As Range
Dim strData As String
Dim strTempFile As String
Dim strPath As String
strPath = Environ("USERPROFILE") & "\Desktop\HBT.txt"
Set Meeting = Worksheets("Patient").Range("CN21:CO55")
Set MeetingComments = Worksheets("Patient").Range("CN21:CO58")
Set Phone = Worksheets("Patient").Range("CS21:CT33")
Set PhoneComments = Worksheets("Patient").Range("CS21:CT36")
If Worksheets("Patient").Range("BB9").Value = 1 Then MeetingComments.Copy
If Worksheets("Patient").Range("BB9").Value = 2 Then Meeting.Copy
If Worksheets("Patient").Range("BB9").Value = 3 Then PhoneComments.Copy
If Worksheets("Patient").Range("BB9").Value = 4 Then Phone.Copy
' get the clipboard data
' magic code for is for early binding to MSForms.DataObject
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
strData = .GetText
End With
' write to temp file
strTempFile = strPath
With CreateObject("Scripting.FileSystemObject")
' true to overwrite existing temp file
.CreateTextFile(strTempFile, True).Write strData
End With
' open notepad with tempfile
Shell "cmd /c ""notepad.exe """ & strTempFile & """", vbHide
End Sub
The runtime error occurs at the following line:
.CreateTextFile(strTempFile, True).Write strData
I have been trying to identify what the variable factor is that triggers the runtime error 5 for weeks. I can't find a pattern.
Thanks
Copy Range to String
The other day, someone mentioned in the comments that Dao is not working supposedly due to a Windows or Office update.
Anyways, here's a simple workaround that may serve you well for such small ranges.
Option Explicit
Sub CopyEventToNotepad()
Dim rgAddresses As Variant
rgAddresses = VBA.Array("CN21:CO55", "CN21:CO58", "CS21:CT33", "CS21:CT36")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Patient")
Dim rg As Range: Set rg = ws.Range(rgAddresses(ws.Range("BB9").Value - 1))
Dim FilePath As String
FilePath = Environ("USERPROFILE") & "\Desktop\HBT.txt"
Dim RangeString As String: RangeString = StringRangeRows(rg)
With CreateObject("Scripting.FileSystemObject")
.CreateTextFile(FilePath, True).Write RangeString
End With
Shell "cmd /c ""notepad.exe """ & FilePath & """", vbHide
End Sub
Function StringRangeRows( _
ByVal rg As Range, _
Optional ByVal CellDelimiter As String = vbTab, _
Optional ByVal LineDelimiter As String = vbLf) _
As String
Dim cLen As Long: cLen = Len(CellDelimiter)
Dim arg As Range, rrg As Range, rCell As Range, RangeString As String
For Each arg In rg.Areas
For Each rrg In arg.Rows
For Each rCell In rrg.Cells
RangeString = RangeString & CStr(rCell.Value) & CellDelimiter
Next rCell
RangeString = Left(RangeString, Len(RangeString) - cLen) _
& LineDelimiter
Next rrg
Next arg
StringRangeRows = Left(RangeString, Len(RangeString) - Len(LineDelimiter))
End Function
I have a code that has been running just fine, however, suddenly I am getting the following error:
I get the error in all the old files as well, even after completely shutting down excel. I also tried adding "AccessibilityCplAdmin 1.0 Type Library", which helped at first but doesn't anymore.
The error is in line "dData(dr, 1) = sheet.Name"
Does anyone know how this could be solved?
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Application.AutomationSecurity = msoAutomationSecurityLow
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As Range: Set dCell = ws_macro.Range(dfcAddress) 'where to write old tabs
Dim dCell_new As Range: Set dCell_new = ws_macro.Range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xlsb*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
Range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xlsb*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As Range: Set rng = ActiveSheet.Range("F2:F100")
Dim cel As Range
For Each cel In rng 'look at first 100 different rows
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
Call Copy_cells(wb_from, new_wb)
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
Set new_wb = Workbooks.Open(sFilePath_newfile)
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").Range("A1:A100").ClearContents
Next
Sheets("Engine").Range("A1:B100").ClearContents
new_wb.Close SaveChanges:=False
RefreshLink_folder (sFolderPath_new)
IsSuccess = True
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.ScreenUpdating = True
End Sub
I have a macro that loops through the files in a folder in which the original excel with the macro lies. It then does a bunch of copy paste for each of the files in the folder. The macro works correctly for the first file in the folder, however, it then stops. Does anyone know why this is so (the starts when it says "Get the list of other tabs (column A)")? There are no errors, the macro just stops looping.
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As range: Set dCell = ws_macro.range(dfcAddress) 'where to write old tabs
Dim dCell_new As range: Set dCell_new = ws_macro.range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Dim sFileName As String: sFileName = Dir(sFolderPath & "*.xls*")
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Get the list of other tabs (column A)
Do While Len(sFileName) > 0
If StrComp(sFileName, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & sFileName
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As range: Set rng = ActiveSheet.range("F2:F100")
Dim cel As range
For Each cel In rng 'look at first 100 different tabs
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & sFileName
End If
sFileName = Dir
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").range("A1:B100").ClearContents
Loop
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
While it may be difficult to determine why it stops looping by observation/review...code can usually be re-organized to help narrow down where/what the problem is.
Given that it currently stops looping after processing the first file, it is clear that Dir is (for whatever reason) returning an empty string after the first file is processed. A first step to debugging the issue would be to isolate the task of getting all the filepaths. Once all the filepaths are determined, Then operate on each file of interest. This step is implemented in the code below.
If loading the filepaths separately fails, then you have a lot less code to debug. If all the filepaths load successfully and the code still fails, then the problem is within the subsequent loop.
As has been commented, it is possible that the code within the Do While loop is somehow preventing Dir from operating properly. If this is the case, then the code below might get the code to work. If the code still fails after collating the filepaths of interest, then start parsing out blocks of functionality within If StrComp(sFileName, macro_filename, vbTextCompare) <> 0 Then. Good luck!
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As Range: Set dCell = ws_macro.Range(dfcAddress) 'where to write old tabs
Dim dCell_new As Range: Set dCell_new = ws_macro.Range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
Range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xls*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As Range: Set rng = ActiveSheet.Range("F2:F100")
Dim cel As Range
For Each cel In rng 'look at first 100 different tabs
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").Range("A1:B100").ClearContents
Next
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
This worked for me in the end if anyone needs the full code. It takes the answer above, and just adjusts some of the variables:
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As range: Set dCell = ws_macro.range(dfcAddress) 'where to write old tabs
Dim dCell_new As range: Set dCell_new = ws_macro.range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xls*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As range: Set rng = ActiveSheet.range("F2:F100")
Dim cel As range
For Each cel In rng 'look at first 100 different rows
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
Set new_wb = Workbooks.Open(sFilePath_newfile)
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").range("A1:A100").ClearContents
Next
Sheets("Engine").range("A1:A100").ClearContents
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
I'm trying to parse through several Excel files and copy data to the currently open file. Here's my code. It fails at this line;
dstDecTbl(rowNdx, DstDecDeath).Value = srcDecData(SrcDecDeath).Value
Can I set ranges in different workbooks and reference them?
Option Explicit
Private Const ConstModuleName As String = "ProcessModule"
Public Sub BuildReport()
Dim srcBook As Workbook
Dim dstBook As Workbook
Dim fileSys As Object
Dim fileDir As Object
Dim fileObj As Object
Dim fileCnt As Integer
Dim srcDecData As Range
Dim srcCntData As Range
Dim dstDecTbl As Range
Dim dstCntTbl As Range
Dim fileNdx As Integer
Dim rowNdx As Integer
On Error GoTo Exception
Set dstBook = Application.ThisWorkbook
Set dstDecTbl = dstBook.Sheets(DstPage).Range(DstDecRange)
Set dstCntTbl = dstBook.Sheets(DstPage).Range(DstCntRange)
Set fileSys = CreateObject("Scripting.FileSystemObject")
Set fileDir = fileSys.GetFolder(DftSourceDir)
rowNdx = 1
fileNdx = 1
For Each fileObj In fileDir.Files
dstBook.Sheets(DstPage).Range(DstFileCount) = fileNdx
dstBook.Sheets(DstPage).Range(DstFileName) = fileObj.Name
Application.ScreenUpdating = False
Set srcBook = Workbooks.Open(fileObj.Path)
Set srcDecData = srcBook.Sheets(SrcPage).Range(SrcDecRange)
dstDecTbl(rowNdx, DstDecDeath).Value = srcDecData(SrcDecDeath).Value
rowNdx = rowNdx + 1
srcBook.Close SaveChanges:=False
Application.ScreenUpdating = True
fileNdx = fileNdx + 1
Next fileObj
Exit Sub
Exception:
Call ExceptionModule.LogException(ConstModuleName & "." & _
"buildReport", Err, vbCritical)
End Sub
Disregard, the error was in the constant definition.