autofilter out of range - vba

Hi I have the following VBA code and it fails at one place time and again.
Sub theathersplitmacro()
Dim SDrv As String
Dim DDrv As String
Dim Sfname As String
Dim Dfname As String
Dim wkbSrc As Workbook
Dim wkbDst As Workbook
Dim shtname(1 To 16) As Variant
Dim i As Integer
Dim Lastrow As Variant
Dim destination_file As String
'Dim regions As String
Dim theater As String
Dim j As Integer
For j = 2 To 9
destination_file = Workbooks("VBA Master
Copy.xlsb").Sheets("Data").Range("A" & j).Value & ".xlsb"
'regions = Workbooks("VBA Master Copy.xlsb").Sheets("Data").Range("C" &
j).Value
theater = Workbooks("VBA Master Copy.xlsb").Sheets("Data").Range("D" &
j).Value
shtname(1) = "DataQTR"
shtname(2) = "DataSWDriver"
shtname(3) = "DataMTD"
shtname(4) = "DataWeekly"
shtname(5) = "DataSoftware"
shtname(6) = "DataCloud"
shtname(7) = "DataServices"
shtname(8) = "TopCustomer"
shtname(9) = "TopDeals"
shtname(10) = "TopPartners"
shtname(11) = "DataForecast"
shtname(12) = "DataFcstCloud"
shtname(13) = "DataFcstSoftware"
shtname(14) = "DataFcstServices"
shtname(15) = "DataServicesSW"
shtname(16) = "TopCustomerDebooking"
SDrv = "C:\Users\skumawat\Documents\Explore\"
Sfname = "Theater_Bookings - New Format with formulae.xlsb"
DDrv = "C:\Users\skumawat\Documents\Explore\"
Dfname = destination_file
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
Set wkbSrc = Workbooks.Open(SDrv & Sfname)
Set wkbDst = Workbooks.Open(DDrv & Dfname)
For i = 1 To 15
wkbSrc.Worksheets(shtname(i)).Activate
Lastrow = wkbSrc.Worksheets(shtname(i)).Range("k" &
Rows.Count).End(xlUp).Row
wkbSrc.Worksheets(shtname(i)).Range("A1:BZ" & Lastrow).Select
If Worksheets(shtname(i)).AutoFilterMode = True Then
wkbSrc.Worksheets(shtname(i)).AutoFilter.Sort.SortFields.Clear
End If
wkbSrc.Worksheets(shtname(i)).Range("A1:BZ" & Lastrow).Select
Selection.AutoFilter
wkbSrc.Worksheets(shtname(i)).Range("$k$1:$k$" & Lastrow).AutoFilter
Field:=11, Criteria1:=theater
Range("$A$1:$BZ$" & Lastrow).SpecialCells(xlCellTypeVisible).Copy
wkbDst.Worksheets(shtname(i)).Range("A1").PasteSpecial
xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Next i
wkbDst.Worksheets("aMapping").Activate
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Workbooks("VBA Master Copy.xlsb").Sheets("Data").Activate
Range("G" & j).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
wkbDst.Worksheets("aMapping").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks
_
:=False, Transpose:=True
Application.CutCopyMode = False
With wkbDst
.Save
.Close
End With
Workbooks("VBA Master Copy.xlsb").Sheets("Data").Range("E" & j).Value =
"Completed"
Next j
With wkbSrc
.Close
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
Workbooks("VBA Master Copy.xlsb").Activate
End Sub
The error I get is in the following line
wkbSrc.Worksheets(shtname(i)).Range("$k$1:$k$" & Lastrow).AutoFilter
Field:=11, Criteria1:=theater


You use a wrong range. To set the autofilter user your range "A1:BZ" & lastrow again. If you use only $K you have no column 11 for your criteria.

Related

Difficulty with the worksheetfunction.match property in VBA

I keep getting the error "Run-time error '91': "Object Variable or With block variable not set" when my macro gets to the line
matchrange = Workbooks("tracker test").Sheets(start_sheet).Range("F" & h).Value
where I am trying to define the PLnumber that will be compared to the PL_compare_list named range. If I try to not define that variable and instead just put the reference directly into my match function on the line below I instead get the error "Run-time error '1004': Unable to get the Match property of the WorksheetFunction class"
What I am trying to do is have this code look at column H on start_sheet to see if it has data yet. then, if it does not, compare the PL numbers on start_sheet in column F to the PL numbers on "Calculation Sheet" in column B to find a row and then open the corresponding file name that is in column A in that row. Thoughts?
Here is my code in its entirety but I think the most relevant bits will be close to the bottom:
Option Explicit
Sub GetFileNames()
Range("A1").Select
ActiveCell.FormulaR1C1 = _
"=REPLACE(CELL(""filename""),FIND(""["",CELL(""filename"")),LEN(CELL(""filename"")),MID(CELL(""filename""),FIND(""]"",CELL(""filename""),1)+1,255))&""_samples shipment PO_PL_Invoice_ attachment\""&TRIM(MID(CELL(""filename""),FIND(""]"",CELL(""filename""),1)+1,255))&""_PL\"""
Range("B1").Select
ActiveCell.FormulaR1C1 = _
"=left(RC[-1],len(RC[-1])-10)"
Range("A1:B1").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim directory As String
directory = Range("B1").Value
Dim start_sheet As String
start_sheet = ActiveSheet.Name
Sheets("Calculation Sheet").Activate
Range("D1") = Sheets(start_sheet).Range("A1").Value
Columns("B:B").Select
Application.CutCopyMode = False
Selection.ClearContents
ActiveSheet.Cells(1, 1).Select
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = directory
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
Dim i As Integer
Dim j As Integer
Dim filenumber As Integer
filenumber = Evaluate("CountA(A:A)")
Columns("A:A").Select
Selection.NumberFormat = "#"
j = 1
For i = 1 To filenumber
If InStr(1, Range("A" & i), "xlsx") Then
ActiveSheet.Range("B" & j).Value = ActiveSheet.Range("D1").Value & ActiveSheet.Range("A" & i).Value
j = j + 1
End If
Next i
Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:E").Select
Application.CutCopyMode = False
Selection.ClearContents
Dim xlfilenumber As Integer
Dim PL_list_length As Integer
xlfilenumber = Evaluate("CountA(A:A)")
ActiveSheet.Range("A1:A" & xlfilenumber).Select
Selection.Name = "list_of_files"
For i = 1 To xlfilenumber
Range("B" & i).Select
ActiveCell.FormulaR1C1 = _
"=MID(RC[-1],FIND(""_PL"",RC[-1],FIND(""_PL\"",RC[-1],1)+4)+1,7)"
Next i
xlfilenumber = Evaluate("CountA(B:B)")
ActiveSheet.Range("A1:A" & xlfilenumber).Select
Selection.Name = "PL_compare_list"
Sheets(start_sheet).Activate
PL_list_length = Evaluate("CountA(F:F)") - 1
Dim h As Integer
Dim g As Integer
Dim filerownum As Integer
Dim matchrange As Range
Dim comparerange As Range
Dim filename As String
For h = 6 To 9
If IsEmpty(Range("J" & h)) Then
matchrange = Workbooks("tracker test").Sheets(start_sheet).Range("F" & h).Value
filerownum = Application.WorksheetFunction.Match(matchrange, Worksheets("Calculation Sheet").Range("PL_compare_list"), 0)
filename = Range("A" & filerownum).Value
Workbooks.Open filename
End If
Next h
Workbooks("tracker test").Sheets(start_sheet).Activate
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
ActiveSheet.Cells(1, 1).Select
Application.CutCopyMode = False
Selection.ClearContents
ActiveSheet.Cells(1, 2).Select
Application.CutCopyMode = False
Selection.ClearContents
ActiveSheet.Cells(1, 3).Select
Application.CutCopyMode = False
Selection.ClearContents
End Sub

Ideally there's a bunch of other changes you should consider, but to address the question of how to handle a failed Match:
Dim filerownum As Variant
Dim rngSrch As Range
Set rngSrch = Worksheets("Calculation Sheet").Range("PL_compare_list")
For h = 6 To 9
If IsEmpty(Range("J" & h)) Then
matchrange = Workbooks("tracker test").Sheets(start_sheet).Range("F" & h).Value
'drop the WorksheetFunction
filerownum = Application.Match(matchrange, rngSrch, 0)
'test for error return value
If Not IsError(filerownum) Then
filename = Range("A" & filerownum).Value
Workbooks.Open filename
End If
End If
Next h

vba code runs in f8 but not in f5

So I have looked at the same question and answer but it does not help with my problem.
here is the code
Private Sub Update_To_Search_Click()
Dim itmx As ListItem
Set itmx = ListView1.FindItem(Number_Selected.Text, lvwText) ', , lvwPartial)
If itmx Is Nothing Then
MsgBox "No Record", vbCritical
Else
ListView1.ListItems(itmx.Index).Selected = True
ListView1.SetFocus
End If
Dim myindex As Integer
Number_Selected.Text = Me.ListView1.SelectedItem
myindex = Me.ListView1.SelectedItem.Index
TextBox2.Text = Me.ListView1.ListItems.Item(myindex).SubItems(1)
TextBox3.Text = Me.ListView1.ListItems.Item(myindex).SubItems(2)
TextBox4.Text = Me.ListView1.ListItems.Item(myindex).SubItems(3)
TextBox5.Text = Me.ListView1.ListItems.Item(myindex).SubItems(4)
TextBox6.Text = Me.ListView1.ListItems.Item(myindex).SubItems(5)
TextBox7.Text = Me.ListView1.ListItems.Item(myindex).SubItems(6)
TextBox8.Text = Me.ListView1.ListItems.Item(myindex).SubItems(7)
TextBox9.Text = Me.ListView1.ListItems.Item(myindex).SubItems(8)
TextBox10.Text = Me.ListView1.ListItems.Item(myindex).SubItems(9)
'Go get the selected line
Dim Base As Worksheet, GoodData As Worksheet
Dim Rng As Range
Set GoodData = Sheets("GoodDBData")
Set Base = Sheets("Data")
Set wb = Workbooks("Staffing LogV1.7.xlsm")
Set listview = wb.Sheets("ListView")
Set fromsearch = wb.Sheets("FromDB")
Set Rng = Base.Range("A20:A28")
FilePath = CStr(wb.Sheets("Data").Cells(2, "A"))
filename = "DB.xlsx"
Application.ScreenUpdating = False
Set DB = Workbooks.Open(FilePath & "\" & filename)
Application.ScreenUpdating = True
Rng.Copy
DB.Sheets("Search Criteria").Range("A2").PasteSpecial _
Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
With DB.Sheets("DB")
With .Rows(1)
Selection.AutoFilter
Selection.AutoFilter
End With
End With
Dim rCrit1 As Range, rCrit2 As Range, rCrit3 As Range, rCrit4 As Range, rCrit5 As Range, rCrit6 As Range, rCrit7 As Range, rCrit8 As Range
Dim rRng1 As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rCrit1 = Sheets("Search Criteria").Range("A2")
Set rCrit2 = Sheets("Search Criteria").Range("B2")
Set rCrit3 = Sheets("Search Criteria").Range("C2")
Set rCrit4 = Sheets("Search Criteria").Range("D2")
Set rCrit5 = Sheets("Search Criteria").Range("E2")
Set rCrit6 = Sheets("Search Criteria").Range("F2")
Set rCrit7 = Sheets("Search Criteria").Range("G2")
Set rCrit8 = Sheets("Search Criteria").Range("H2")
Set rRng1 = Sheets("DB").Range("A1").CurrentRegion
With rRng1
If rCrit1.Value <> "" Then
.AutoFilter field:=11, Criteria1:=rCrit1.Value, Operator:=xlOr
End If
If rCrit2.Value <> "" Then
.AutoFilter field:=7, Criteria1:=rCrit2.Value, Operator:=xlOr
End If
If rCrit3.Value <> "" Then
.AutoFilter field:=13, Criteria1:=rCrit3.Value, Operator:=xlOr
End If
If rCrit4.Value <> "" Then
.AutoFilter field:=14, Criteria1:=rCrit4.Value, Operator:=xlOr
End If
If rCrit5.Value <> "" Then
.AutoFilter field:=16, Criteria1:=rCrit5.Value, Operator:=xlOr
End If
If rCrit6.Value <> "" Then
.AutoFilter field:=30, Criteria1:=rCrit6.Value, Operator:=xlOr
End If
If rCrit7.Value <> "" Then
.AutoFilter field:=32, Criteria1:=rCrit7.Value, Operator:=xlOr
End If
If rCrit8.Value <> "" Then
.AutoFilter field:=37, Criteria1:=rCrit8.Value, Operator:=xlOr
End If
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End sub
The following still does not copy and paste the criteria to look for. For some reason it only copies blanks no data is entered in Searcriteria. rangeA2.
Rng.Copy
DB.Sheets("Search Criteria").Range("A2").PasteSpecial _
Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
I'm at a lost and I'm looking for any help I could get.
Thank you very much

Check this for me.
Replace your code
Base.Select
Base.Range("A7:A15").Select
Selection.Copy
FilePath = CStr(wb.Sheets("Data").Cells(2, "A"))
FileName = "DB.xlsx"
Application.ScreenUpdating = False
Set Db = Workbooks.Open(FilePath & "\" & FileName)
Application.ScreenUpdating = True
Sheets("Search Criteria").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("DB").Select
Rows("1:1").Select
Selection.AutoFilter
Selection.AutoFilter
With
Dim Rng As Range
Set Rng = Base.Range("A7:A15")
FilePath = CStr(wb.Sheets("Data").Cells(2, "A"))
FileName = "DB.xlsx"
Application.ScreenUpdating = False
Set Db = Workbooks.Open(FilePath & "\" & FileName)
Application.ScreenUpdating = True
Rng.Copy
Db.Sheets("Search Criteria").Range("A2").PasteSpecial _
Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
With Db.Sheets("Search Criteria")
With .Rows(1)
'~~> REST OF THE CODE
End With
End With
Now Try it?

Ways to improve macros execution time

I have created a macro, which runs fine but, for no reason I can explain, takes so long to finish. I have tried running the macro line to line and cannot figure out which part of the process takes so long. I can only imagine that it is the part where I delete rows based on backround color. I have built several macros with similar lines of code and the performance was way better.
Sub Pharma_Stock_Report()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim lastrow3 As Long
Dim cell As Range
Dim DeleteRange As Range
spath1 = Application.ThisWorkbook.Path & "\Pharma replenishment.xlsm"
spath2 = Application.ThisWorkbook.Path & "\NOT OK.xlsx"
Workbooks.Open spath1
Workbooks.Open spath2
Set ws1 = Workbooks("Pharma Stock Report.xlsm").Worksheets("Pharma Stock Report")
Set ws2 = Workbooks("Pharma replenishment.xlsm").Worksheets("Replenishment")
Set ws3 = Workbooks("NOT OK.xlsx").Worksheets("Sheet1")
ws1.Cells.Clear
lastrow1 = ws2.Range("A" & Rows.Count).End(xlUp).Row
ws2.Range("A4:G" & lastrow1).Copy
With ws1.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
End With
Application.CutCopyMode = False
Workbooks("Pharma replenishment.xlsm").Close
lastrow2 = ws1.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In ws1.Range("D2:D" & lastrow2)
If Not cell.Interior.ColorIndex = 2 Or cell.Interior.ColorIndex = -4142 Then
If DeleteRange Is Nothing Then
Set DeleteRange = cell
Else
Set DeleteRange = Union(DeleteRange, cell)
End If
End If
Next cell
If Not DeleteRange Is Nothing Then DeleteRange.EntireRow.Delete
ws3.Range("H1:J1").Copy
With ws1.Range("H1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
End With
lastrow3 = ws1.Range("D" & Rows.Count).End(xlUp).Row
ws1.Range("H2:H" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:H,3,FALSE),"""")"
With Range("H2:H" & lastrow3)
.Value = .Value
.NumberFormat = "dd/mm/yyyy"
End With
ws1.Range("I2:I" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),"""")"
With Range("I2:I" & lastrow3)
.Value = .Value
.NumberFormat = "dd/mm/yyyy"
End With
ws1.Range("J2:J" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:J,5,FALSE),"""")"
With Range("J2:J" & lastrow3)
.Value = .Value
.NumberFormat = "dd/mm/yyyy"
End With
Application.CutCopyMode = False
Workbooks("NOT OK.xlsx").Close
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

Macro to consolidate data from 2 different worksheets of each wkbook inside subfolders and show result in separate worksheets for each subfolder

I'm doing an office project where i need to create a macro.
I have a folder with 30 subfolders each named after our branches. For example- Chicago branch, New York branch etc. Each subfolder contains a number of workbooks and each workbook has a number of worksheet full of data.
I made a macro to extract a number of cells from the worksheet called "Menu" and one cell from the worksheet called "score" and paste it in a new workbook.
I have researched online and made two separate macros to get the data from the two seperate worksheets. But it only works if I select all the files I want inside a subfolder.
I also found some code to access folders inside subfolders but I couldn't compile it with my current code. In addition, I couldn't join the two macros I made, so it'd require only one button instead of two.
Now, I need a macro which will ask me to select a folder and go to the subfolders and folders inside the subfolders by itself and consolidate the data in a new workbook BUT in separate worksheets based on the Subfolders( the branch named ones, not the folders inside subfolders.
The data extracted from workbooks in the folders inside subfolders need to be in the worksheet named after the subfolder.) The idea is to have to press the command button once to get all the data extracted from that folder and subfolders inside at once as its too hectic to use my code 30 times for 30 subfolders to get data of 30 branches.
"Macro for extracting data from the worksheet MENU of each workbook"
Private Sub CommandButton1_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
Dim aCell As Range, bCell As Range
Dim lastRow As Long, i As Long
Dim ExitLoop As Boolean
ShName = "Menu" '<---- Change
Set Rng = Range("B9:b13") '<---- Change
'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
MultiSelect:=True)
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 = Sheets("Sheet1")
'The links to the first workbook will start in row 2
RwNum = 2
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)
'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
Range("b2").Select
ActiveCell.FormulaR1C1 = "Client Name"
Range("C2").Select
ActiveCell.FormulaR1C1 = "Occupation"
Range("D2").Select
ActiveCell.FormulaR1C1 = "Date"
Range("E2").Select
ActiveCell.FormulaR1C1 = "Insured Location"
Range("F2").Select
ActiveCell.FormulaR1C1 = "Serveyed by"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=""Property Risk Scores Updated as at """
Rows("1:1").RowHeight = 27.75
Range("B1").Select
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("C1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("c1").Select
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("b2:f2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Font.Bold = True
Application.ScreenUpdating = True
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
For Each SummWks In ThisWorkbook.Sheets
Set aCell = SummWks.Rows(2).Find(what:="Date", LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
ExitLoop = False
If Not aCell Is Nothing Then
Set bCell = aCell
SummWks.Columns(aCell.Column).NumberFormat = "dd/mm/yyyy;#"
lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
SummWks.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
With SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i)
.FormulaR1C1 = .Value
End With
Next i
SummWks.Columns(aCell.Column).AutoFit
Do While ExitLoop = False
Set aCell = SummWks.Rows(2).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
SummWks.Columns(aCell.Column).NumberFormat = "dd/mm/yyyy;#"
lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
SummWks.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).FormulaR1C1 = _
SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).Value
Next i
Else
ExitLoop = True
End If
Loop
End If
Next
End Sub
"Macro for extracting data from the worksheet SCORE of each workbook"
Private Sub CommandButton2_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
Dim aCell As Range, bCell As Range
Dim lastRow As Long, i As Long
Dim ExitLoop As Boolean
ShName = "score" '<---- Change
Set Rng = Range("f65") '<---- Change
'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
MultiSelect:=True)
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 = Sheets("Sheet1")
'The links to the first workbook will start in row 2
RwNum = 2
For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 6
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)
'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
Range("g2").Select
ActiveCell.FormulaR1C1 = "Score"
Range("g2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Font.Bold = True
Application.ScreenUpdating = True
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
For Each SummWks In ThisWorkbook.Sheets
Set aCell = SummWks.Rows(2).Find(what:="Score", LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
ExitLoop = False
If Not aCell Is Nothing Then
Set bCell = aCell
SummWks.Columns(aCell.Column).NumberFormat = "0%"
lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
SummWks.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
With SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i)
.FormulaR1C1 = .Value
End With
Next i
SummWks.Columns(aCell.Column).AutoFit
Do While ExitLoop = False
Set aCell = SummWks.Rows(2).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
SummWks.Columns(aCell.Column).NumberFormat = "0%"
lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
SummWks.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).FormulaR1C1 = _
SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).Value
Next i
Else
ExitLoop = True
End If
Loop
End If
Next
End Sub

#dave I'm posting this as an answer because it's too long to post as a comment. Can you please check which parts need correction? Thanks a lot!
Also I needed a code that will put the branch data in different worksheets. For example in sheet 1 will contain all the info I extracted from X branch folder,sheet 2 will contain all the info I extracted from Y branch folder.
Private Sub CommandButton1_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
Dim aCell As Range, bCell As Range
Dim lastRow As Long, i As Long
Dim ExitLoop As Boolean
Dim oSheet: Set oSheet = ThisWorkbook.Worksheets("Sheet to copy to in here")
Dim oFso: Set oFso = CreateObject("Scripting.FileSystemObject")
Dim oFolder: Set oFolder = oFso.GetFolder("Path to Desktop Branch Data folder in here")
Dim oSubFolder, oBranchWorkbook, oWorksheet
For Each oSubFolder In oFolder.SubFolders
Debug.Print "Looking inside " & oSubFolder.Name
Set oBranchWorkbook = Workbooks.Open(oSubFolder.Path & "*.xl*")
' Now you have the Info.xls from whichever branch folder we are in open
Set oWorksheet = oBranchWorkbook.Worksheets("Menu")
' Extract whatever you need from Menu to the current workbook, e.g.
oSheet.Range("B2").Value = oWorksheet.Range("B9:b13").Value
' Once you complete the Menu extract, change oWorksheet to point at Score
Set oWorksheet = oBranchWorkbook.Worksheets("Score")
' Extract whatever you need from Score to the current workbook, e.g.
oSheet.Range("G2").Value = oWorksheet.Range("F65").Value
'Once you have completed all the extracts you need, close the branch workbook
oBranchWorkbook.Close
Next ' Move onto next subfolder and repeat the process...
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 = Sheets("Sheet1")
'The links to the first workbook will start in row 2
RwNum = 2
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)
'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
Range("b2").Select
ActiveCell.FormulaR1C1 = "Client Name"
Range("C2").Select
ActiveCell.FormulaR1C1 = "Occupation"
Range("D2").Select
ActiveCell.FormulaR1C1 = "Date"
Range("E2").Select
ActiveCell.FormulaR1C1 = "Insured Location"
Range("F2").Select
ActiveCell.FormulaR1C1 = "Serveyed by"
Range("g2").Select
ActiveCell.FormulaR1C1 = "Score"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=""Property Risk Scores Updated as at """
Rows("1:1").RowHeight = 27.75
Range("B1").Select
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("C1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("c1").Select
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("b2:g2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Font.Bold = True
Application.ScreenUpdating = True
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
For Each SummWks In ThisWorkbook.Sheets
Set aCell = SummWks.Rows(2).Find(what:="Date", LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
ExitLoop = False
If Not aCell Is Nothing Then
Set bCell = aCell
SummWks.Columns(aCell.Column).NumberFormat = "dd/mm/yyyy;#"
lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
SummWks.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
With SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i)
.FormulaR1C1 = .Value
End With
Next i
SummWks.Columns(aCell.Column).AutoFit
Do While ExitLoop = False
Set aCell = SummWks.Rows(2).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
SummWks.Columns(aCell.Column).NumberFormat = "dd/mm/yyyy;#"
lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
SummWks.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).FormulaR1C1 = _
SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).Value
Next i
Else
ExitLoop = True
End If
Loop
End If
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
For Each SummWks In ThisWorkbook.Sheets
Set aCell = SummWks.Rows(2).Find(what:="Score", LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
ExitLoop = False
If Not aCell Is Nothing Then
Set bCell = aCell
SummWks.Columns(aCell.Column).NumberFormat = "0%"
lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
SummWks.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
With SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i)
.FormulaR1C1 = .Value
End With
Next i
SummWks.Columns(aCell.Column).AutoFit
Do While ExitLoop = False
Set aCell = SummWks.Rows(2).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
SummWks.Columns(aCell.Column).NumberFormat = "0%"
lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
SummWks.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).FormulaR1C1 = _
SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).Value
Next i
Else
ExitLoop = True
End If
Loop
End If
Next
Next
End Sub

Okay, I think I understand the requirement. Try something along these lines?
Dim oSheet
Dim oFso : Set oFso = CreateObject("Scripting.FileSystemObject")
Dim oFolder : Set oFolder = oFso.GetFolder("Path to Desktop Branch Data folder in here")
Dim oSubFolder, oBranchWorkbook, oWorksheet, iSheet
iSheet = 1
For Each oSubFolder in oFolder.SubFolders
Debug.Print "Looking inside " & oSubFolder.Name
' Set the sheet to copy to (1 on the first, 2 on the second etc)
' this would be better if the sheets were named for each branch folder
' as then instead of iSheet you could use oSubFolder.Name and it wouldn't matter if things were out of order for some reason...
Set oSheet = ThisWorkbook.Worksheets(iSheet)
For Each oFile in oSubFolder.Files
If Right(oFile.Name,3) = "xls" or Right(oFile.Name, 4) = "xlsx" Then
Set oBranchWorkbook = Workbooks.Open(oSubFolder.Path & oFile.Name)
' Now you have the Info.xls from whichever branch folder we are in open
Set oWorksheet = oBranchWorkbook.Worksheets("Menu")
' Extract whatever you need from Menu to the current workbook, e.g.
oSheet.Range("A1").Value = oWorksheet.Range("B1").Value
' Once you complete the Menu extract, change oWorksheet to point at Score
Set oWorksheet = oBranchWorkbook.Worksheets("Score")
' Extract whatever you need from Score to the current workbook, e.g.
oSheet.Range("A1").Value = oWorksheet.Range("B1").Value
'Once you have completed all the extracts you need, close the branch workbook
oBranchWorkbook.Close
End If
Next
iSheet = iSheet + 1 ' increment sheet counter
Next ' Move onto next subfolder and repeat the process...

Copy cells between worksheets

I need the macro to open wkbk(B) goto row (??) based value entered in wkbk(A) copy certain colmns and paste back to col (j14) in wkbk (A).
Sub AutofillData()
Dim wkbkSource As Workbook
Dim strPath As String
Dim myRange As Range
Dim i As Integer
Dim c As Range
Application.ScreenUpdating = False
strPath = "\\"
Set wkbkSource = Workbooks.Open(strPath & Range("A13").Value & ".xls?")
Windows("Book1.xlsm").Activate
Set myRange = Range("i14:i25")
For Each c In myRange
i = c.Value
wkbkSource.Activate
Worksheets("Main Data").Select
Range("D" & i & ":O" & i).Select
Selection.Copy
Windows("Book1.xlsm").Activate
Range("J14").Select
Sheets("Data").Cells(Rows.Count, 9).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False
Range("J14").Select
Application.CutCopyMode = False
Next
wkbkSource.Close savechanges:=False
Application.ScreenUpdating = True
End Sub

This will do it
Sub AutofillData()
Dim wkbkSource As Workbook
Dim strPath As String
Dim myRange As Range
Dim i As Integer
Dim c As Range
Dim wkbkTarget As Workbook
Application.ScreenUpdating = False
strPath = "C:\temp\"
Set wkbkA = ThisWorkbook
Set wkbkB = Workbooks.Open(strPath & Range("A13").Value & ".xlsx")
Set myRange = wkbkA.Sheets("Sheet2").Range("i14:i25")
offs = 0
For Each c In myRange
i = c.Value
wkbkB.Worksheets("Main Data").Range("D" & i & ":O" & i).Copy
wkbkA.Sheets("Data").Range("J14").Offset(offs, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=True, Transpose:=False
Application.CutCopyMode = False
offs = offs + 1
Next
wkbkB.Close savechanges:=False
Application.ScreenUpdating = True
End Sub