R1C1 Notation To Pick Index Range for Index,Match,Match - excel

I cannot seem to get this line of code working:
For Each errCell In BET_ws.Range("E5:E" & lastrow).Offset(0, 1 + i)
errCell.FormulaR1C1 = "=INDEX('" & cNameAndPath & BET_ws.Cells(errCell.Row,
2).Value & "'!R2C3:R1000C200,MATCH(R2C[-1],'" & cNameAndPath &
BET_ws.Cells(errCell.Row, 2).Value & "'!R2C2:R400C2,0),MATCH(RC3,'" & cNameAndPath
& BET_ws.Cells(errCell.Row, 2).Value & "'!R1C3:R1C200,0))"
Next errCell
I keep getting an object undefined error. Is it a problem with my R1C1 notation or is it an issue with BET_ws.Cells(errCell.Row,2).Value statement? In Column B the tab name needed for my INDEX reference is in the RC2 location. Not sure how to correct the issue. cNameAndPath is defined and is pulling the value I want. Another formula is running in the adjacent range with no problem.
Here is most of the code if it helps:
Sub BetConverter()
Dim wbkTarget As Workbook
Dim fNameAndPath As Variant
Dim cNameAndPath As Variant
Dim cFileName As String
Dim cFilePath As String
Dim BET_ws As Worksheet
Dim shtTarget As Worksheet
Dim ws As Worksheet
Dim lrow As Long 'last row variable
Dim lcol As Long 'last column variable
Dim lastrow As Long
Dim i As Integer
Dim cwbTarget As Workbook
Dim errCell As Range
'kill clunky processes
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
'delete summary tab if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("BET Consolidated").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'On Error GoTo Errhandler
Sheets.Add(After:=Sheets("Macro")).Name = "BET Consolidated" 'create new tab
Set BET_ws = ThisWorkbook.Sheets("BET Consolidated")
MsgBox ("Please Select the Bid Entry Tool to be Consolidated in the following File Dialog Box.")
fNameAndPath = Application.GetOpenFilename(Title:="Select Bid Entry Tool to be Consolidated")
If fNameAndPath = False Then Exit Sub
Set wbkTarget = Workbooks.Open(fNameAndPath)
MsgBox ("Please Select the MDB for Comparison in the following File Dialog Box.")
cNameAndPath = Application.GetOpenFilename(Title:="Select the MDB for Comparison")
If cNameAndPath = False Then Exit Sub
Set cwbTarget = Workbooks.Open(cNameAndPath)
cFileName = Mid$(cNameAndPath, InStrRev(cNameAndPath, "\") + 1)
cFilePath = Left$(cNameAndPath, InStrRev(cNameAndPath, "\"))
Do While shtTarget Is Nothing
For Each ws In wbkTarget.Sheets
If ws.Name Like "*H*" Then
Set shtTarget = ws
End If
Next ws
Loop
lrow = shtTarget.Cells(Rows.Count, 11).End(xlUp).Row
With shtTarget.Range("K2:K" & lrow)
BET_ws.Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
With shtTarget.Range("J2:J" & lrow)
BET_ws.Range("B1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
With shtTarget.Range("O2:O" & lrow)
BET_ws.Range("C1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
With shtTarget.Range("P2:P" & lrow)
BET_ws.Range("D1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
i = 0
For Each ws In wbkTarget.Worksheets
If ws.Name Like "*H*" Then
Set shtTarget = ws
lastrow = shtTarget.Cells(shtTarget.Rows.Count, 27).End(xlUp).Row
With shtTarget.Range("AA1:AA" & lastrow)
BET_ws.Range(Range("D1").Offset(0, 1 + i).Address).Resize(.Rows.Count, .Columns.Count) = .Value
End With
For Each errCell In BET_ws.Range("E5:E" & lastrow).Offset(0, 1 + i)
errCell.FormulaR1C1 = "=INDEX('" & cNameAndPath & BET_ws.Cells(errCell.Row, 2).Value & "'!R2C3:R1000C200,MATCH(R2C[-1],'" & cNameAndPath & BET_ws.Cells(errCell.Row, 2).Value & "'!R2C2:R400C2,0),MATCH(RC3,'" & cNameAndPath & BET_ws.Cells(errCell.Row, 2).Value & "'!R1C3:R1C200,0))"
Next errCell
For Each errCell In BET_ws.Range("F5:F" & lastrow).Offset(0, 1 + i)
errCell.FormulaR1C1 = "=IF(RC[-2]=RC[-1],""MATCH"",""DOES NOT MATCH"")"
Next errCell
i = i + 3
End If
Next ws
Also tried like this:
For Each errCell In BET_ws.Range("E5:E" & lastrow).Offset(0, 1 + i)
tName = BET_ws.Cells(errCell.Row, 2).Value
errCell.FormulaR1C1 = "=INDEX('" & cFilePath & "[" & cFileName & "]" & tName & "'!R2C3:R1000C200,MATCH(R2C[-1],'" & cFilePath & "[" & cFileName & "]" & tName & "'!R2C2:R400C2,0),MATCH(RC3,'" & cFilePath & "[" & cFileName & "]" & tName & "'!R1C3:R1C200,0))"
Next errCell

Related

error in copying range based on specific value from different workbokks

The below code is to copy the entire row based on specific value from different workbooks.
From First workbook copy entire sheet then find the specific value in specified column range then union of range copy to another sheet.
Next workbook get the last row and paste the union of range below the last row
the code is not working properly.
It copies only blank rows
Public Function SheetFromCodeName(Name As String, wbK As Workbook) As Worksheet
Dim Wks As Worksheet
For Each Wks In wbK.Worksheets
If Wks.CodeName = Name Then
Set SheetFromCodeName = Wks
Exit For
End If
Next Wks
End Function
Private Sub a()
Dim wbK As Workbook, Wks As Worksheet, fName As String, cop1 As String, cop2 As String, C As Range, N As Long
Application.Run "TurnOff"
Sheet42.Range("A6:EC9999").Clear
For Each C In Sheet2.Range("K1:AT1")
If C.Value <> "" Then
fName = ThisWorkbook.Path & "\" & C.Value & ".xlsb"
If Dir(fName) <> "" Then
Set wbK = Workbooks.Open(fName, Password:="Ssca#1818", WriteResPassword:="Ssca#1818", UpdateLinks:=0)
Set Wks = SheetFromCodeName("Sheet5", wbK)
Sheet41.Range("A:EC").EntireColumn.Hidden = False
Sheet41.Cells.Clear
Wks.Unprotect "1818"
Wks.Cells.Copy
Sheet41.Range("A1").PasteSpecial xlPasteValues
Sheet41.Range("A1").PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Dim xRg, raSource As Range
Dim i, lr As Long
Dim MyValue As Variant
i = Sheet41.UsedRange.Rows.Count
Set xRg = Union(Sheet41.Range("BX6:BX" & i), Sheet41.Range("BZ6:BZ" & i), Sheet41.Range("CB6:CB" & i), Sheet41.Range("CD6:CD" & i), Sheet41.Range("CF6:CF" & i), Sheet41.Range("CH6:CH" & i), _
Sheet41.Range("CJ6:CJ" & i), Sheet41.Range("CL6:CL" & i), Sheet41.Range("CN6:CN" & i), Sheet41.Range("CP6:CP" & i), Sheet41.Range("CR6:CR" & i), Sheet41.Range("CT6:CT" & i), _
Sheet41.Range("CV6:CV" & i), Sheet41.Range("CX6:CX" & i), Sheet41.Range("CZ6:CZ" & i), Sheet41.Range("DB6:DB" & i))
MyValue = Sheet42.Range("K1").Value
For N = 1 To xRg.Rows.Count
For Each KCELL In Intersect(xRg, xRg.Rows(N).EntireRow)
If KCELL.Value = MyValue Then
If raSource Is Nothing Then
Set raSource = Range(Cells(KCELL.Row, 1), Cells(KCELL.Row, 133))
Else
Set raSource = Union(raSource, Range(Cells(KCELL.Row, 1), Cells(KCELL.Row, 133)))
End If
Exit For
End If
Next
Next N
raSource.Copy ' Getting error from here
lr = Sheet42.Range("A:EC").Find("*", , xlValues, , xlByRows, xlPrevious).Row
If lr < 6 Then
Sheet42.Range("A6").PasteSpecial xlPasteAllUsingSourceTheme
Else
Sheet42.Range("A6").PasteSpecial xlPasteAllUsingSourceTheme
End If
Application.CutCopyMode = False
'Sheet42.Activate
wbK.Close False
Set raSource = Nothing
Set xRg = Nothing
Set i = Nothing
'Set N = Nothing
Sheet41.Cells.Clear
cop1 = cop1 & C.Value & vbCr
Else
cop2 = cop2 & C.Value & vbCr
End If
End If
Next
Application.Run "TurnOn"
MsgBox "Copied Books" & vbCr & cop1 & vbCr & "These books do not exist" & vbCr & cop2
End Sub

VBA error in copying the workbooks to new workbook

I am trying the combine the all workbooks from a folder after some changes into on one new workbook, each workbook has only one sheet. But my code is not woking at following line:
wksCurSheet.Copy After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Could you please check what is causing the error?
Sub CombineIDBISheet()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim wksCurSheet As Worksheet
Dim wbkCurBook As Workbook
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
Set wbkCurBook = ActiveWorkbook
If Range("B4") = "Search Criteria" Then
Cells.WrapText = False
Cells.UnMerge
Dim x
With Range("d7", Range("d" & Rows.Count).End(xlUp))
x = .Address
.Value = Evaluate("index(date(mid(" & x & ",7,4),mid(" & x & ",4,2),left(" & x & ",2))+timevalue(right(" & x & ",8)),,)")
.NumberFormat = "dd/mm/yyyy hh:mm:ss"
With .Offset(, 1)
.TextToColumns .Cells(1), 1, FieldInfo:=Array(1, 4)
.NumberFormat = "dd/mm/yyyy"
End With
End With
With Range("j7:k" & Cells(Rows.Count, 4).End(xlUp).Row)
.Value = .Value
.UnMerge
End With
Range("b3:b5").Copy Range("c3:c5")
Columns("a:b").EntireColumn.Delete
Columns("i").EntireColumn.AutoFit
Columns("L:p").EntireColumn.Delete
Else
End If
Range("B4").ClearContents
wksCurSheet.Copy After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
ActiveWorkbook.Close SaveChanges:=True
End With
xFileName = Dir
Loop
End If
End Sub

Sheets("Name").select/activate not working. Just acts like it isn't even there [duplicate]

The code below is a template used for a bunch of automations. all works fine until the line where i'm trying to select a certain cell. I'm doing that so that if somewhere in the code I add some code that manipulates a cell somewhere far in the document, I want it to select the first cell with data (in my case it's a variable ExcelPasteTo), so that when the user open the file,it doesn't shift to cell AZX298, for example.
So far, i'm getting stuck at this line
.Range(ExcelPasteTo).Select
what's weird is, in the case, this code creates 2 files, first file has 1 sheet, second has 8 sheets. it works fine for the first file, selects the correct cell, saves, closes, opens the second one, pastes the data and then gets stuck at this line
the error is
Error 1004
Select method of Range class failed
Option Explicit
Public Sub MainProcedure1()
Dim FormattedDate As Date, RunDate As Date
Dim ReportPath As String, MonthlyPath As String, CurPath As String, ProjectName As String, ExcelFileName As String, FinalExcelFileName As String
Dim TableName As String, TemplateFileName As String, SheetToSelect As String, ExcelSheetName As String, CurSheetName As String
Dim CurRowNum As Long, LastRow As Long, FirstRowOfSection As Long, LastRowOfSection As Long
Dim i As Integer, CurCell As Variant, CurRange As Range
Dim wbkM As Workbook, wbkNewFile As Workbook, wbk2 As Workbook, wbk3 As Workbook, wbk4 As Workbook
Dim wksReportDates As Worksheet, wksFilesToExportEMail As Worksheet, wksCopyFrom As Worksheet, wksCopyTo As Worksheet, wks3 As Worksheet, wks4 As Worksheet, wks5 As Worksheet
Dim rngCopyFrom As Range, rngCopyTo As Range
Dim Offset1 As Long, Offset2 As Long
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
Application.EnableEvents = False
CurPath = ThisWorkbook.Path & "\"
CurRowNum = 2
With ThisWorkbook.Sheets("QReportDates")
FormattedDate = .Range("A2").Value
RunDate = .Range("B2").Value
ReportPath = .Range("C2").Value
MonthlyPath = .Range("D2").Value
ProjectName = .Range("E2").Value
End With
Set wbkM = Workbooks(ProjectName & ".xlsm")
Set wksReportDates = wbkM.Sheets("QReportDates")
Set wksFilesToExportEMail = wbkM.Sheets("QFilesToExportEMail")
With wksFilesToExportEMail
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set CurRange = .Range("B" & CurRowNum & ":B" & LastRow)
For Each CurCell In CurRange
If CurCell <> "" Then
ExcelFileName = .Range("B" & CurRowNum).Value
FinalExcelFileName = .Range("B" & CurRowNum).Value
LastRowOfSection = .Range("B" & CurRowNum & ":B" & LastRow).Find(what:=ExcelFileName, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
TemplateFileName = .Range("F" & CurRowNum).Value
FirstRowOfSection = .Columns(2).Find(ExcelFileName).Row
TableName = .Range("A" & CurRowNum).Value
ExcelSheetName = .Range("C" & CurRowNum).Value
If ExcelSheetName = "" Then
ExcelSheetName = TableName
End If
If CurRowNum = FirstRowOfSection Then
SheetToSelect = ExcelSheetName
End If
If IsNull(TemplateFileName) Or TemplateFileName = "" Then
Set wbkNewFile = Workbooks.Add
Else
Set wbkNewFile = Workbooks.Open(CurPath & TemplateFileName)
End If
wbkNewFile.SaveAs MonthlyPath & FinalExcelFileName
For i = CurRowNum To LastRowOfSection
With wksFilesToExportEMail
TableName = .Range("A" & i).Value
ExcelSheetName = .Range("C" & i).Value
ExcelTemplate = .Range("D" & i).Value
ExcelPasteTo = .Range("E" & i).Value
End With
If ExcelSheetName = "" Then
ExcelSheetName = TableName
End If
Set wksCopyFrom = wbkM.Sheets(TableName)
Set wksCopyTo = wbkNewFile.Sheets(ExcelSheetName)
If ExcelTemplate = "format" Then
Set wbkNewFile = Workbooks(FinalExcelFileName)
wbkNewFile.Sheets.Add(after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = ExcelSheetName
With wksCopyFrom
CurLastColumn = MyColumnLetter(.Range("A1").CurrentRegion.Columns.Count)
CurLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rngCopyFrom = .Range("A1:" & CurLastColumn & CurLastRow)
End With
With wksCopyTo
Offset1 = Range(CurLastColumn & CurLastRow).Row + (Range(ExcelPasteTo).Row - 1)
Offset2 = Range(CurLastColumn & CurLastRow).Column + (Range(ExcelPasteTo).Column - 1)
Set rngCopyTo = .Range(.Cells(Range(ExcelPasteTo).Row, Range(ExcelPasteTo).Column), .Cells(Offset1, Offset2))
End With
rngCopyTo.Value = rngCopyFrom.Value
Application.Run "'personal.xlsb'!FormatTheBasics"
ElseIf ExcelTemplate = "" Then
With wksCopyFrom
CurLastColumn = MyColumnLetter(.Range("A1").CurrentRegion.Columns.Count)
CurLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rngCopyFrom = .Range("A2:" & CurLastColumn & CurLastRow)
End With
With wksCopyTo
Offset1 = Range(CurLastColumn & CurLastRow).Row + (Range(ExcelPasteTo).Row - 2)
Offset2 = Range(CurLastColumn & CurLastRow).Column + (Range(ExcelPasteTo).Column - 1)
Set rngCopyTo = .Range(.Cells(Range(ExcelPasteTo).Row, Range(ExcelPasteTo).Column), .Cells(Offset1, Offset2))
End With
rngCopyTo.Value = rngCopyFrom.Value
ElseIf ExcelTemplate Like "*TEMPLATE*" Then
wbkM.Sheets(ExcelTemplate).Copy after:=wbkNewFile.Sheets(1)
wbkM.Sheets(1).Name = ExcelSheetName
wbkM.Sheets(ExcelSheetName).Move after:=Workbooks(Workbooks.Count)
wbkNewFile.wksCopyTo.Select
With wksCopyFrom
CurLastColumn = MyColumnLetter(.Range("A1").CurrentRegion.Columns.Count)
CurLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set rngCopyFrom = .Range("A2:" & CurLastColumn & CurLastRow)
End With
With wksCopyTo
'A2 = (2,1)
Offset1 = Range(CurLastColumn & CurLastRow).Row + (Range(ExcelPasteTo).Row - 2)
Offset2 = Range(CurLastColumn & CurLastRow).Column + (Range(ExcelPasteTo).Column - 1)
Set rngCopyTo = .Range(.Cells(Range(ExcelPasteTo).Row, Range(ExcelPasteTo).Column), .Cells(Offset1, Offset2))
End With
rngCopyTo.Value = rngCopyFrom.Value
End If
With wksCopyTo
.Range(ExcelPasteTo).Select
End With
Next i
If LastRowOfSection < LastRow Then
CurRowNum = LastRowOfSection + 1
Else
CurRowNum = LastRowOfSection
End If
End If
With wksCopyTo
If CheckSheet("Sheet1") Then
Worksheets("Sheet1").Delete
End If
End With
wbkNewFile.Worksheets(SheetToSelect).Select
wbkNewFile.Save
wbkNewFile.Close
Set wbkNewFile = Nothing
Set wksCopyTo = Nothing
Set rngCopyTo = Nothing
Set wksCopyFrom = Nothing
Set rngCopyFrom = Nothing
If LastRowOfSection >= LastRow Then
Exit For
End If
Next CurCell
CurSheetName = ""
With wksFilesToExportEMail
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set CurRange = .Range("A2:A" & LastRow)
For Each CurCell In CurRange
If CurCell <> "" Then
CurSheetName = CurCell
If CheckSheet(CurSheetName) Then
Worksheets(CurSheetName).Delete
End If
End If
Next CurCell
End With
End With
wbkM.Worksheets("QFilesToExportEMail").Delete
wbkM.Worksheets("QReportDates").Delete
wbkM.Save
Set CurCell = Nothing: Set CurRange = Nothing: Set wbkM = Nothing
End Sub
So all I'm trying to do is to make sure that after all manipulations, the document always opens at the beginning. And I was doing that by selecting A2 or A3
Is this what you are trying?
Application.Goto Reference:=ws.Range("A2"), Scroll:=True
Note: For this to work, ensure that the Sheet is visible and unprotected. And if protected, then "Select locked cells" is activated.

VBA Excel - Application or object oriented error with =HYPERLINK

I have a problem with a VBA-based hyperlink in Excel 2016. I want to add a "Navigation" sheet in front of all other sheets but I have an issue with "=HYPERLINK". My code is the following:
Dim wbBook As workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Dim temp As Variant
Set wbBook = ActiveWorkbook
wbBook.Sheets.Add(Before:=Worksheets(1)).Name = "Navigation"
Set wsActive = wbBook.ActiveSheet
With wsActive
.Name = "Navigation"
With .Range("A1:A1")
.Value = VBA.Array("Mitarbeiter")
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
wsSheet.Activate
With wsActive
Worksheets("Navigation").Cells(lnRow, 1).Formula = _
"=HYPERLINK(" & Chr(34) & "#" & "'" & wsSheet.Name & "'" & "!A" & lnRow & Chr(34) & ";" & Chr(34) & wsSheet.Name & Chr(34) & ")"
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
The problem I have is that when I add an "=" in front of HYPERLINK, the error "Anwendungs- oder objektorientierter Fehler" (application or object oriented error) pops up. If I run the macro without the "=", the program works but I manually have to add the equation sign in the navigation sheet.
Cheers in advance!
Since you are already using VBA, why not the VBA capability of Adding Hyperlinks (with .Hyperlinks.Add).
You can read about it more on MSDN
I reduced a the use of ActiveSheet, and Activate.
Code
Option Explicit
Sub TestHyperlink()
Dim wbBook As Workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Dim temp As Variant
Set wbBook = ActiveWorkbook
Set wsActive = wbBook.Sheets.Add(Before:=Worksheets(1))
With wsActive
.Name = "Navigation"
With .Range("A1:A1")
.Value = VBA.Array("Mitarbeiter")
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
With wsSheet
.Hyperlinks.Add Anchor:=Worksheets("Navigation").Range("A" & lnRow), _
Address:="", SubAddress:="'" & .Name & "'!" & .Range("A" & lnRow).Address, _
TextToDisplay:="#" & .Name
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
End Sub
Try using a comma to separate the parameters of the formula instead of a semicolon. I think forcing formulae into cells like this ignores localisation.
With wsActive
Worksheets("Navigation").Cells(lnRow, 1).Formula = _
"=HYPERLINK(" & Chr(34) & "#" & "'" & wsSheet.Name & "'" & "!A" & lnRow & Chr(34) & "," & Chr(34) & wsSheet.Name & Chr(34) & ")"
End With

VBA Splash Screen

I wonder whether someone may be able to help me please.
I'm trying to put together a script which produces a "Splash" screen whilst a a lengthy Excel macro is being run.
I've done quite a bit of research on this and found an example here.
I've set up my form with the following code in it's properties:
' Set true when the long task is done.
Public TaskDone As Boolean
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = Not TaskDone
End Sub
I've then created a module which contains this piece of code:
Now Removed in Working Code
The problem I have is that I'm really unsure how to integrate this with the macro I want to run whilst the form is displayed.
The code below is the macro I'll be running:
Updated Code - Working Script
Sub CreateAllData()
Dim cell As Range
Dim cll As Range
Dim DestWB As Workbook
Dim dR As Long
Dim excelfile As Variant
Dim Fd As FileDialog
Dim i As Long
Dim LastRow As Long
Dim LR As Long
Dim MidFile As String
Dim MyNames As Variant
Dim sFile As String
Dim sMidFile As Variant
Dim SourceSheet As String
Dim StartRow As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim frm As frmSplash
Dim j As Integer
' Display the splash form non-modally.
Set frm = New frmSplash
frm.TaskDone = False
frm.prgStatus.Value = 0
frm.Show False
For j = 1 To 1000
DoEvents
Next j
Set DestWB = ActiveWorkbook
SourceSheet = "Input"
StartRow = 2
sMidFile = "January, February, March, April, May, June, July, August, September, October, November, December"
MidFile = InputBox("Enter the name of the monthly folder e.g. 'January'", "All Time Recording Data")
If InStr(sMidFile, MidFile) = 0 Or MidFile = "" Then
MsgBox "A valid month name was not entered"
End
End If
Application.ScreenUpdating = False
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(1))
newsht.Name = "All Data"
With newsht
With .Range("B5")
.Value = "All Data"
.Offset(2, 0).Resize(, 14).Value = Array("Project LOB", "Resource LOB", "Staff Name", "Task", "Project Name", "Project Code", "Project ID", "Job Role", "Month", "Forecast Hrs", "Forecast FTE", "Actuals Hrs", "Actuals FTE", "Flexible Resource")
End With
End With
Range("B7:O7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\All Data\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("All Data").Range("B" & DestWB.Worksheets("All Data").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":M" & LastRow).Copy
DestWB.Worksheets("All Data").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("All Data").Range("B8:N" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("All Data").Range("B8:N" & LastRow).Font.Size = 10
DestWB.Worksheets("All Data").Range("K8:N" & LastRow).NumberFormat = "#,##0.00"
DestWB.Worksheets("All Data").Range("K8:N" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 10
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(2))
newsht.Name = "All Projects"
With newsht
With .Range("B5")
.Value = "All Projects"
.Offset(2, 0).Resize(, 7).Value = Array("Project LOB", "Project Name", "Project Code", "Project ID", "Project Priority", "Project Start Date", "Project Finish Date")
End With
End With
Range("B7:H7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\All Projects\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("All Projects").Range("B" & DestWB.Worksheets("All Projects").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":G" & LastRow).Copy
DestWB.Worksheets("All Projects").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("All Projects").Range("B8:H" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("All Projects").Range("B8:H" & LastRow).Font.Size = 10
DestWB.Worksheets("All Projects").Range("H8:H" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 20
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(3))
newsht.Name = "All Resources"
With newsht
With .Range("B5")
.Value = "All Resources"
.Offset(2, 0).Resize(, 8).Value = Array("Staff Name", "Resource LOB", "Job Role", "Month", "Staff FTE", "Flexible Resource", "Line Manager", "Date of Termination")
End With
End With
Range("B7:I7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\All Resources\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("All Resources").Range("B" & DestWB.Worksheets("All Resources").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":E" & LastRow).Copy
DestWB.Worksheets("All Resources").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("All Resources").Range("B8:I" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("All Resources").Range("B8:I" & LastRow).Font.Size = 10
DestWB.Worksheets("All Resources").Range("F8:H" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 30
Set sht = Sheets("All Resources")
MyNames = Array("AllResSName", "AllResLOB", "AllResJRole", "AllResPeriod", "AllResFTE", "AllResFlex", "AllResLineM", "AllResTerm")
i = 0
LR = sht.Range("B" & Rows.Count).End(xlUp).Row
For Each cll In Ash.Range("B8:I8").Cells
Range(sht.Cells(8, cll.Column), sht.Cells(LR, cll.Column)).Name = MyNames(i)
i = i + 1
Next cll
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(4))
newsht.Name = "Flexible Resources List"
With newsht
With .Range("B5")
.Value = "Flexible Resources List"
.Offset(2, 0).Resize(, 6).Value = Array("Resource LOB", "Staff Name", "Grade", "Flexible Resource", "Line Manager", "Date of Termination")
End With
End With
Range("B7:G7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\Flexible Resources\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("Flexible Resources List").Range("B" & DestWB.Worksheets("Flexible Resources List").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":G" & LastRow).Copy
DestWB.Worksheets("Flexible Resources List").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("Flexible Resources List").Range("B8:G" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("Flexible Resources List").Range("B8:G" & LastRow).Font.Size = 10
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 40
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(5))
newsht.Name = "IDEAS"
With newsht
With .Range("B5")
.Offset(2, 0).Resize(, 5).Value = Array("Staff Name", "Project Name", "Project ID", "Month", "Actuals FTE")
End With
End With
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\IDEAS\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("IDEAS").Range("B" & DestWB.Worksheets("IDEAS").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":E" & LastRow).Copy
DestWB.Worksheets("IDEAS").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("IDEAS").Range("B8:F" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("IDEAS").Range("B8:F" & LastRow).Font.Size = 10
DestWB.Worksheets("IDEAS").Range("F8:F" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 50
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(6))
newsht.Name = "Profile Data"
With newsht
With .Range("B5")
.Value = "Flexible Resource Profile Data"
.Offset(2, 0).Resize(, 4).Value = Array("Resource LOB", "Staff Name", "Project Name", "Job Role")
End With
.Range("F7").Formula = "=B3"
.Range("G7").Resize(, 13).Formula = "=EOMONTH(F7,0)+1"
With Range("T7")
.Value = "Flexible Resource"
.Offset(, 1).Value = "Line Manager"
.Offset(, 2).Value = "Date of Termination"
End With
End With
Range("B7:V7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\Managers List\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("Profile Data").Range("B" & DestWB.Worksheets("Profile Data").Rows.Count).End(xlUp).Row + 1
If dR < 8 Then dR = 7 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":Q" & LastRow).Copy
DestWB.Worksheets("Profile Data").Cells(dR, "C").PasteSpecial xlValues
DestWB.Worksheets("Profile Data").Range("B8:V" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("Profile Data").Range("B8:V" & LastRow).Font.Size = 10
DestWB.Worksheets("Profile Data").Range("F8:S" & LastRow).NumberFormat = "#,##0.00"
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 60
Call AllDataSignals
Call AllResourcesSignals
Call IDEASFormat
Call DeleteBlankRowsCopy
Call AllDataFormat
Call AllProjectsFormat
Call AllResourcesFormat
Call FlexibleResourcesListFormat
frm.prgStatus.Value = 100
' Close the splash form.
frm.TaskDone = True
Unload frm
Sheets("Macros").Select
Application.ScreenUpdating = True
End Sub
I just wondered whether someone could possibly look at this please and offer some guidance on how I may integrate the two.
Many thanks and regards
You need to replace this portion of the code:
' Perform the long task.
For i = 0 To 100 Step 10
frm.prgStatus.Value = i
' Waste some time.
For j = 1 To 1000
DoEvents
Next j
Next i
...with your long running code and include the frm.prgStatus.Value = i (or similar) in your code to update the progress bar.
EDIT
If you call your sub from and it is in another module, it will not have direct access to update the progress bar. One option is to pass in the progress bar object as a parameter to your sub, like this:
Public Sub CreateAllData(byref MyProgBar As ProgressBar)
Within your sub, you would update the progress bar by doing something like this:
MyProgBar.Value = 1
You will call your sub like this:
CreateAllData frm.prgStatus

Resources