Hi All,
I am a newbie VB coder and I'm trying to create a macro that will automatically open up various files, scroll through the workbooks and for those workbooks that have a finance code is a specific cell, copy some of the data to a different workbook. The data I want to copy is located in relation to the 2010, which is why I have the find statement. The file locations will be in the NameList sheet.
I've cobbled this code from various boards on the web, but I can't get it to work. Originally, my problem was with the "Next sht" statement towards the end, when I would get the "next without for" error. Now, something has changed and the code breaks at the Cells.Find statement with "Object variable or with block variable not set"
Any help would be greatly appreciated.
Thanks!!
I am a newbie VB coder and I'm trying to create a macro that will automatically open up various files, scroll through the workbooks and for those workbooks that have a finance code is a specific cell, copy some of the data to a different workbook. The data I want to copy is located in relation to the 2010, which is why I have the find statement. The file locations will be in the NameList sheet.
I've cobbled this code from various boards on the web, but I can't get it to work. Originally, my problem was with the "Next sht" statement towards the end, when I would get the "next without for" error. Now, something has changed and the code breaks at the Cells.Find statement with "Object variable or with block variable not set"
Any help would be greatly appreciated.
Thanks!!
Code:
Sub Macro6()
Dim rngName As Range
Sheets("NameList").Activate 'name list will have all the file locations of the workbooks i want to copy fomr
Range("$A$1").Activate
Set rngName = ActiveCell
Do Until rngName.Value = ""
Workbooks.Open Filename:=rngName.Value
Dim sht As Worksheet
For Each sht In ThisWorkbook.Worksheets
If Range("$B$2") <> "" Then 'B2 needs to be non-empty in order to be included
Range("A:IV").Select
Selection.EntireColumn.Hidden = False
With Selection
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Dim Rng1, Rng2, Rng3, Rng4, Rng5, Rng6, Rng7, Rng8, Rng9, Rng10, Rng11, Rng12, Rng13 As Range 'these are all the ranges i want to copy
Rows("1:1").Select
Cells.find(What:="2010", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Set Rng1 = Range("A1:b90")
Set Rng2 = Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(89, 1))
Set Rng3 = Range(ActiveCell.Offset(0, 4), ActiveCell.Offset(89, 4))
Set Rng4 = Range(ActiveCell.Offset(0, 7), ActiveCell.Offset(89, 7))
Set Rng5 = Range(ActiveCell.Offset(0, 10), ActiveCell.Offset(89, 10))
Set Rng6 = Range(ActiveCell.Offset(0, 13), ActiveCell.Offset(89, 13))
Set Rng7 = Range(ActiveCell.Offset(0, 16), ActiveCell.Offset(89, 16))
Set Rng8 = Range(ActiveCell.Offset(0, 19), ActiveCell.Offset(89, 19))
Set Rng9 = Range(ActiveCell.Offset(0, 22), ActiveCell.Offset(89, 22))
Set Rng10 = Range(ActiveCell.Offset(0, 25), ActiveCell.Offset(89, 25))
Set Rng11 = Range(ActiveCell.Offset(0, 28), ActiveCell.Offset(89, 28))
Set Rng12 = Range(ActiveCell.Offset(0, 31), ActiveCell.Offset(89, 31))
Set Rng13 = Range(ActiveCell.Offset(0, 34), ActiveCell.Offset(89, 34))
Union(Rng1, Rng2, Rng3, Rng4, Rng5, Rng6, Rng7, Rng8, Rng9, Rng10, Rng11, Rng12, Rng13).Copy
Windows("Processingrollup.xls").Activate 'this is the destination file
Sheets("Budget").Select
Range("$A$1").Select
If Range("$A$1").Value = "" Then ActiveSheet.Paste Else
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If
Selection.End(xlDown).Select
ActiveCell.EntireRow.Delete
Next sht
strname = InStrRev(rngName.Value, "\")
strname = Right(rngName.Value, Len(rngName.Value) - strname)
Workbooks(strname).Close savechanges:=False
Set rngName = rngName.Offset(1, 0)
Sheets("NameList").Activate
Loop
End Sub
Last edited by a moderator: