Loop Through Workbooks and copy data based on conditions

[mjc279]

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!!

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

 

[hiker95]

mjc279,

Welcome to the MrExcel board.



See:

    '********** This 'End If' was probably missing **********
    End If

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit

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


    '********** This 'End If' was probably missing **********
    End If
    
    
  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

 

[mjc279]

Hi Hiker,

Thanks for the reply.

I added the end if statement that you suggested, but now I'm getting an end if without block if statement. I was wondering if all the "active" selections are what is causing the problem