Getting after running a VBA code

[agrawaltanu21]

I have 10 workbooks in a directory, each has only one sheet. I have another main spreadsheet where I am doing all the calculations. This main spreadsheet has sheets with the same names with only an extension added at the beginning. To be more specific, let's say the workbooks in the directory are named: Analyst1.xlsx, Analyst2.xlsx and the main spreadsheet has sheets named Analyst1,Analyst2. The reason for that I have other sheets in that main workbook.

I need to copy the information in sheet1 of Analyst1.xlsx into the sheet named Analyst1 and so on.. on the main spreadsheet if that sheet exists in the main workbook.
I have run one code and its working fine. after running this code i am getting Msg Box 400 form already displayed cant show modally. I am also pasting my code.

Sub copy()


Dim PathOfWorkbboks
Dim objFolder As Object
Dim objFile As Object
Dim OpenBook As Workbook
Dim Main
Dim objName
Dim Sheetname
Dim Sheetnamee
Dim currentName As String
Dim x As Integer

Application.ScreenUpdating = True
Application.DisplayAlerts = True

'Main = "Cop.xlsx" 'Change name of your main workbook here

'Windows(Main).Activate
PathOfWorkbboks = "C:\Users\tanu_agrawal1\Downloads\Automation\d" ' Change to the path where all workbooks are
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(PathOfWorkbboks)


For x = 1 To 22
Sheets("Analystname").Activate (I have given all name of tabs here-Analys1,Analyst2.....)
Sheetname = Cells(x, 1)
Sheetnamee = Sheetname & ".xlsm"
Application.ScreenUpdating = False
Application.DisplayAlerts = False


'Windows(Main).Activate
For Each objFile In objFolder.Files
objName = objFSO.Getfilename(objFile.Path)
'Sheetname = Cells(x, 1)
'Windows(Main).Activate
If objName = Sheetnamee Then
'Windows(Main).Activate
Set OpenBook = Application.Workbooks.Open(objFile)
'Workbooks.Open objFile
OpenBook.Sheets("Time Survey").Range("B7:LA15").copy

'Main = "Cop.xlsx"
ThisWorkbook.Worksheets(Sheetname).Range("b5").PasteSpecial xlPasteValues
OpenBook.Sheets("Time Survey").Range("B18:LA23").copy
ThisWorkbook.Worksheets(Sheetname).Range("b16").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Workbooks(objName).Close savechanges:=False

End If
Next
Next x


End Sub

 

[NdNoviceHlp]

Hi agrawaltanu21. Naming a sub "Copy" isn't so good as XL has a specific meaning for copy. Anyways, U can trial this. HTH. Dave

Sub copyOver()
Dim FSO As Object, objFSO As Object
Dim PathOfWorkbboks As String
Dim objFolder As Object
Dim objFile As Object
Dim objName As Object
Dim Sheetname As String
Dim Sheetnamee As String
Dim x As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False
PathOfWorkbboks = "C:\Users\tanu_agrawal1\Downloads\Automation\d\" ' Change to the path where all workbooks are
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(PathOfWorkbboks)
For x = 1 To 22
Sheetname = CStr(Sheets("Analystname").Cells(x, 1))
Sheetnamee = Sheetname & ".xlsm"
For Each objFile In objFolder.Files
If objFile.Name = Sheetnamee Then
Workbooks.Open Filename:=objFile
Workbooks(objFile.Name).Sheets("Time Survey").Range("B7:LA15").copy
ThisWorkbook.Worksheets(Sheetname).Range("b5").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Workbooks(objFile.Name).Sheets("Time Survey").Range("B18:LA23").copy
ThisWorkbook.Worksheets(Sheetname).Range("b16").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Workbooks(objName.Name).Close savechanges:=False
Exit For
End If
Next objFile
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objFSO = Nothing
Set objFolder = Nothing
End Sub

ps. please use code tags