Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
VBA does not work
Helo,
Please help me, when I run this code, there is no error message, it opens the worksheet, but it does not copy the data from the source range. This is the code: Sub Rectangle2_Click() Dim FileNameXls As Variant Dim SummWks As Worksheet Dim ColNum As Integer Dim myCell As Range, Rng As Range Dim RwNum As Long, FNum As Long, FinalSlash As Long Dim ShName As String, PathStr As String Dim SheetCheck As String, JustFileName As String Dim JustFolder As String ShName = "SUMMARY" '<---- Change Set Rng = Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D9 5,F95,D103,D104") '<---- Change 'Select the files with GetOpenFilename FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _ MultiSelect:=True) ' Set FileNameXls = Workbooks.Open( _ ' Filename:=PathStr & FileNameXls, _ ' UpdateLinks:=0, _ ' Password:="TopSecret", _ 'WriteResPassword:="TopSecret") 'Set FileNameXls = ActiveWorkbook If IsArray(FileNameXls) = False Then 'do nothing Else With Application ..Calculation = xlCalculationManual ..ScreenUpdating = False End With 'Add a new workbook with one sheet for the Summary Set SummWks = Workbooks.Add(1).Worksheets(1) 'The links to the first workbook will start in row 2 RwNum = 1 For FNum = LBound(FileNameXls) To UBound(FileNameXls) ColNum = 1 RwNum = RwNum + 1 FinalSlash = InStrRev(FileNameXls(FNum), "\") JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1) JustFolder = Left(FileNameXls(FNum), FinalSlash - 1) 'copy the workbook name in column A SummWks.Cells(RwNum, 1).Value = JustFileName 'build the formula string JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''") PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!" On Error Resume Next SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1)) If Err.Number < 0 Then 'If the sheet not exist in the workbook the row color will be Yellow. SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _ ..Interior.Color = vbYellow Else For Each myCell In Rng.Cells ColNum = ColNum + 1 SummWks.Cells(RwNum, ColNum).Formula = _ "=" & PathStr & myCell.Address Next myCell End If On Error GoTo 0 Next FNum ' Use AutoFit to set the column width in the new workbook SummWks.UsedRange.Columns.AutoFit MsgBox "The Summary is ready, save the file if you want to keep it" With Application ..Calculation = xlCalculationAutomatic ..ScreenUpdating = True End With End If End Sub Thanks for any help. Frank |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
VBA does not work
Hello,
After I modified again, the path and the file name has been listed, but the content of the source rage not show up. I appreciate anybody help. Thanks in advance, Frank "Frank Situmorang" wrote: Helo, Please help me, when I run this code, there is no error message, it opens the worksheet, but it does not copy the data from the source range. This is the code: Sub Rectangle2_Click() Dim FileNameXls As Variant Dim SummWks As Worksheet Dim ColNum As Integer Dim myCell As Range, Rng As Range Dim RwNum As Long, FNum As Long, FinalSlash As Long Dim ShName As String, PathStr As String Dim SheetCheck As String, JustFileName As String Dim JustFolder As String ShName = "SUMMARY" '<---- Change Set Rng = Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D9 5,F95,D103,D104") '<---- Change 'Select the files with GetOpenFilename FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _ MultiSelect:=True) ' Set FileNameXls = Workbooks.Open( _ ' Filename:=PathStr & FileNameXls, _ ' UpdateLinks:=0, _ ' Password:="TopSecret", _ 'WriteResPassword:="TopSecret") 'Set FileNameXls = ActiveWorkbook If IsArray(FileNameXls) = False Then 'do nothing Else With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With 'Add a new workbook with one sheet for the Summary Set SummWks = Workbooks.Add(1).Worksheets(1) 'The links to the first workbook will start in row 2 RwNum = 1 For FNum = LBound(FileNameXls) To UBound(FileNameXls) ColNum = 1 RwNum = RwNum + 1 FinalSlash = InStrRev(FileNameXls(FNum), "\") JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1) JustFolder = Left(FileNameXls(FNum), FinalSlash - 1) 'copy the workbook name in column A SummWks.Cells(RwNum, 1).Value = JustFileName 'build the formula string JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''") PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!" On Error Resume Next SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1)) If Err.Number < 0 Then 'If the sheet not exist in the workbook the row color will be Yellow. SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _ .Interior.Color = vbYellow Else For Each myCell In Rng.Cells ColNum = ColNum + 1 SummWks.Cells(RwNum, ColNum).Formula = _ "=" & PathStr & myCell.Address Next myCell End If On Error GoTo 0 Next FNum ' Use AutoFit to set the column width in the new workbook SummWks.UsedRange.Columns.AutoFit MsgBox "The Summary is ready, save the file if you want to keep it" With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End If End Sub Thanks for any help. Frank |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
need a function that will work using multiple work books and sheet | Excel Worksheet Functions | |||
extracting totals from 1 work sheet to another work work sheet | Excel Discussion (Misc queries) | |||
Counting dates in multiple work sheets and work books | Excel Discussion (Misc queries) | |||
Is there away to keep "auto save" from jumping to the first work sheet in the work book? | New Users to Excel | |||
Spin button in a work sheet - how do I make it work? | Excel Worksheet Functions |