• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA macro, For loop gives Runtime error 9-subscript out of range

Ria

Member
Hi All;
I am using excel 2003, not an expert and neither a programmer, but can do some basic programming.
I have 2 excel files (1st one COT_DATA.xls is destination file with multiple sheets and all sheets need to be processed same way. 2nd file is "annualof.xls" source file with lots of columns & data)

On destination file, I have button connected to macro, on press button. It insert line, read text/contents of cell A1, go to source file, look in column A and search the text, if found only first occurence then it will select entire row of active cell then copy and paste it back to destination file. Loop through all sheets in destination file. Working fine. Problem with this approach is copied row has lots of extra columns we do not need. After copy and paste into source file, we need to delete manually all extra columns for all sheets and we do not to do that.
1. On match of active cell/row, I want to copy only selected cells e.g. cell C, F, L or so. When I run macro for this approach, it gives me "Runtime error 9, subscript out of range" and high light code row "Worksheets(i).Select". If I put curser, (i) shows me value = 2 and first sheet in destination file has been processed but loop stuck in second iteration. I do not know what is wrong with For loop. Help please.

2. If no. 1 above get fixed then I want to match 2 columns from destination file/sheet to source file in 2 columns using IF AND condition. e.g. from destination file read text/contents of cell A1 & A4 (which is date), then go to source file, search first occurence in column A, if found then in active cell row, cell C search for date (value of cell A4 from destionation file/sheet). if both conditions match/true then copy selected cells from this row and paste back to destination file/sheet.
if solution of no. 2 above is same as no 1 above and only need to add AND with IF condition then ignore no.2, I will fix it but if need to use different approach then please fix it.

3. On workbook/file COT_DATA.xls, I want to have button linked to macro. On press it should show me file select dialogue box, where I can choose source file path/file and then that file path/file should be used as source file for processing. This source file path should remain untill I change, regardless closing and reopening workbook COT_DATA. We do use this functionaly, sometime when using different person on different computers.

Both files are attached. Please let me know if I can explain in better way or any question.
Files are too big so deleted lots of data but will give you to work on.
File COT_DATE, deleted sheets but you can create other sheets with Name: NG and enter test in A1: 'OATS - CHICAGO BOARD OF TRADE then search.

Thanks

Ria
 

Attachments

  • COT_DATA.xls
    594 KB · Views: 3
  • annualof.xls
    597 KB · Views: 4
You can drop most of the code which use select, selection and activate. It comes through macro recorder.

If you have been programming for some time then you will definitely learn that part fairly fast.

Here's a code similar to what you have written. Please test this on a backup.
Code:
Sub UpdateDataMacro2()
Dim wbDest As Workbook, wbSrc As Workbook
Dim wsSrc As Worksheet
Dim rFind As Range
Set wbDest = ActiveWorkbook

On Error Resume Next
Set wbSrc = Workbooks("annualof.xls")
On Error GoTo 0
If wbSrc Is Nothing Then MsgBox "Source workbook not open!", vbInformation: Exit Sub

Set wsSrc = wbSrc.Sheets(1)
For i = 1 To wbDest.Sheets.Count
  Set rFind = wsSrc.Cells.Find(What:=wbDest.Sheets(i).Cells(1, 1).Value, After _
  :=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows _
  , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
  If Not rFind Is Nothing Then
  wbDest.Sheets(i).Rows("3:3").Insert xlDown
  wsSrc.Range("C" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("A3")
  wsSrc.Range("H" & rFind.Row & ":J" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("B3")
  wsSrc.Range("L" & rFind.Row & ":M" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("E3")
  wsSrc.Range("P" & rFind.Row & ":Q" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("G3")
  End If
Next i

wbSrc.Close

End Sub

If you want to know the reason for subscript 9 worksheets(i) part then here it is:
If the Source workbook has less number of sheets than your destination workbook then it is likely to happen. When a reference is unqualified then Excel assumes it is with the Active workbook and then it tries to locate worksheet 2 in source workbook that doesn't exist.
 
You can drop most of the code which use select, selection and activate. It comes through macro recorder.

If you have been programming for some time then you will definitely learn that part fairly fast.

Here's a code similar to what you have written. Please test this on a backup.
Code:
Sub UpdateDataMacro2()
Dim wbDest As Workbook, wbSrc As Workbook
Dim wsSrc As Worksheet
Dim rFind As Range
Set wbDest = ActiveWorkbook

On Error Resume Next
Set wbSrc = Workbooks("annualof.xls")
On Error GoTo 0
If wbSrc Is Nothing Then MsgBox "Source workbook not open!", vbInformation: Exit Sub

Set wsSrc = wbSrc.Sheets(1)
For i = 1 To wbDest.Sheets.Count
  Set rFind = wsSrc.Cells.Find(What:=wbDest.Sheets(i).Cells(1, 1).Value, After _
  :=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows _
  , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
  If Not rFind Is Nothing Then
  wbDest.Sheets(i).Rows("3:3").Insert xlDown
  wsSrc.Range("C" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("A3")
  wsSrc.Range("H" & rFind.Row & ":J" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("B3")
  wsSrc.Range("L" & rFind.Row & ":M" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("E3")
  wsSrc.Range("P" & rFind.Row & ":Q" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("G3")
  End If
Next i

wbSrc.Close

End Sub

If you want to know the reason for subscript 9 worksheets(i) part then here it is:
If the Source workbook has less number of sheets than your destination workbook then it is likely to happen. When a reference is unqualified then Excel assumes it is with the Active workbook and then it tries to locate worksheet 2 in source workbook that doesn't exist.

Hi Shrivallabha:

Thanks for quick response.

I tested it and works only if destination workbook has only one sheet. My destination workbook has many sheets with different names (in cell A1, search text is different). file is too big that is why can not send you file with many sheets in it. Please have a look again.

No doubt your code is short and simple. Mine was generated from macro recording and was modified. This is what makes you IT professional.

Thanks

Ria
 
Hi Ria,

The code above should loop through all sheets in the destination workbook. When I tested here I understood that "COT_DATA" is destination workbook. Is that correct understanding?

If yes, then it should loop through all sheets in COT_DATA since we are using
Code:
For i = 1 To wbDest.Sheets.Count
:
:
Next i

Or is it that it should loop through all sheets in Source workbook (annualof.xls)? Currently the code looks at first sheet in Source workbook only. Please let us know.
 
Hi Ria,

The code above should loop through all sheets in the destination workbook. When I tested here I understood that "COT_DATA" is destination workbook. Is that correct understanding?

If yes, then it should loop through all sheets in COT_DATA since we are using
Code:
For i = 1 To wbDest.Sheets.Count
:
:
Next i

Or is it that it should loop through all sheets in Source workbook (annualof.xls)? Currently the code looks at first sheet in Source workbook only. Please let us know.
Hi Hi Shrivallabha:

Thanks for reply. It is working now, do not know what went wrong before. Finally working with solution you provided.

If we search based on IF....AND condition how to handle it. Here is scenario:
IF Destination book: cell A1 (text string for search, you already provided solution) and cell A3 (date format: 09/09/2014) match in source book. IF both condition meet THEN do nothing ELSE copy selected cells from active cell row from source book (only one sheet) to destination book (multiple sheets) using loop.
Reason is in source book, text string repeats many times but date NEVER repeats.
I tried to declare date: Dim rFindDate As Range, it does not do anything
Tried: Dim rFindDate As String, gives compile error-object required
Tried: Dim rFindDate As Date, gives compile error-object required

I hope it is not too much to ask.

Thanks

Ria
 
Hi Ria,

Diwali preparations keep me away. I hope you've found of out some solution to your situation. If not, please try as below.
Code:
  If Not rFind Is Nothing Then
  If wsSrc.Range("C" & rFind.Row).Value <> wbDest.Sheets(i).Range("A3").Value Then
  wbDest.Sheets(i).Rows("3:3").Insert xlDown
  wsSrc.Range("C" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("A3")
  wsSrc.Range("H" & rFind.Row & ":J" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("B3")
  wsSrc.Range("L" & rFind.Row & ":M" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("E3")
  wsSrc.Range("P" & rFind.Row & ":Q" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("G3")
  Else
  MsgBox "Record for date :" & Sheets(i).Range("A3").Text & " already updated!", vbInformation
  End If
  End If
Please note added if condition for comparing dates.
 
  • Like
Reactions: Ria
Hi Ria,

Diwali preparations keep me away. I hope you've found of out some solution to your situation. If not, please try as below.
Code:
  If Not rFind Is Nothing Then
  If wsSrc.Range("C" & rFind.Row).Value <> wbDest.Sheets(i).Range("A3").Value Then
  wbDest.Sheets(i).Rows("3:3").Insert xlDown
  wsSrc.Range("C" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("A3")
  wsSrc.Range("H" & rFind.Row & ":J" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("B3")
  wsSrc.Range("L" & rFind.Row & ":M" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("E3")
  wsSrc.Range("P" & rFind.Row & ":Q" & rFind.Row).Copy Destination:=wbDest.Sheets(i).Range("G3")
  Else
  MsgBox "Record for date :" & Sheets(i).Range("A3").Text & " already updated!", vbInformation
  End If
  End If
Please note added if condition for comparing dates.

EXCELLENT Shrivallabha.
Code is working as I want it.
Last thing I am working on is, get file path through open file dialogue box (select file path and file), then put it on Destination workbook (COT_DATA.xls) e.g. cell M1. then assign this cell value in code as file path of source book. if file path changes then instead going into code and changing file path, one can click on button on DESTINATION file/workbook and select file path. This file path will stay until we change it, regardless how many time we open/close destination file.
Attached is destination file and here is full scenario how it works.
Weekly, we get zip file and put it in specific folder.
Open destination workbook (COT_DATA.xls) and click update triggers macro.
It deletes existing unzipped file and folder, then unzip file and put it into new folder with same name as zip file.
Open source book and get data from source file and paste it into destination file. close source book.
Currently, if I do not use file path via open file dialogue box then code is working fine. But if try to assign file path via open file dialogue box then get Run time error 75, Path/File access error.

No rush, when you get time, please have a look.
Enjoy your dewali.
HAPPY DEWALI.

Ria
 

Attachments

  • COT_DATA.xls
    585.5 KB · Views: 2
Hi Ria,

Need to know couple of things.

1. The code for update has been written for looping through all sheets in destination workbook then why do you need to put the name of source file on each sheet of destination workbook. Will it not be sufficient to get the source file name on first sheet only? Of course, that part works so I don't see any issues there but it is just redundant information.

2. It is always good to specify exactly where you get this error. I see there are 4 modules and each contains some code. Assuming we are discussing the modified code we have worked on in this thread here's what I'd suggest.

Do this on backup
At first add this line at the top of Module 4 above line Function IsFileOpen(FileName As String). This is a public variable which we will be using across modules.
Code:
Public strWorkbook As String

Then change TestFileOpen sub routine in Module 4 as below:
Code:
Sub TestFileOpen()
strWorkbook = ThisWorkbook.Sheets(1).Range("M1").Value
  If Not IsFileOpen(strWorkbook) Then
  Workbooks.Open strWorkbook
  End If
End Sub

Once you finish these updates then change the UpdateDataMacro2 as below:
Code:
Sub UpdateDataMacro2()
Dim wbDest As Workbook, wbSrc As Workbook
Dim wsSrc As Worksheet
Dim rFind As Range
Dim strSrc As String
Set wbDest = ActiveWorkbook
'======================
'Call macro to UnZip file
UnZipMe
'======================
'function call to test if file is already open

'Here we check for the desired workbook and set it as the source TestFileOpen
On Error Resume Next
strSrc = Mid(strWorkbook, InStrRev(strWorkbook, Application.PathSeparator) + 1, 199)
Set wbSrc = Workbooks(strSrc)
On Error GoTo 0
If wbSrc Is Nothing Then MsgBox "Source workbook not open!", vbInformation: Exit Sub

Set wsSrc = wbSrc.Sheets(1)
For I = 1 To wbDest.Sheets.Count
   
  '===================
  Set rFind = wsSrc.Cells.Find(What:=wbDest.Sheets(I).Cells(1, 1).Value, After _
  :=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows _
  , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
   
  'If Not rFindD Is Nothing Then
  'If wsSrc.Range("C" & rFindT.Row).Value <> wbDest.Sheets(i).Range("A3").Value Then
  If wbDest.Sheets(I).Range("A3") = wsSrc.Range("C" & rFind.Row).Value Then
  'do nothing
  ' MsgBox "Record for date: " & Sheets(i).Range("A3").Text & " already updated!", vbInformation
  MsgBox "Record for lagest date already updated!", vbInformation
  Else
  wbDest.Sheets(I).Rows("3:3").Insert xlDown
  wsSrc.Range("C" & rFind.Row).Copy Destination:=wbDest.Sheets(I).Range("A3")
  wsSrc.Range("H" & rFind.Row & ":J" & rFind.Row).Copy Destination:=wbDest.Sheets(I).Range("B3")
  wsSrc.Range("L" & rFind.Row & ":M" & rFind.Row).Copy Destination:=wbDest.Sheets(I).Range("E3")
  wsSrc.Range("P" & rFind.Row & ":Q" & rFind.Row).Copy Destination:=wbDest.Sheets(I).Range("G3")
  'Else
  'MsgBox "Record for date :" & Sheets(i).Range("A3").Text & " already updated!", vbInformation
  'MsgBox "Update for date :" & Sheets(i).Range("A3").Text & " done!", vbInformation
  'End If
  End If
  'MsgBox "Update for date :" & Sheets(i).Range("A3").Text & " done!", vbInformation
Next I

 wbSrc.Close

End Sub

Let us know if this is what you were after.
 
Hi Ria,

Need to know couple of things.

1. The code for update has been written for looping through all sheets in destination workbook then why do you need to put the name of source file on each sheet of destination workbook. Will it not be sufficient to get the source file name on first sheet only? Of course, that part works so I don't see any issues there but it is just redundant information.

2. It is always good to specify exactly where you get this error. I see there are 4 modules and each contains some code. Assuming we are discussing the modified code we have worked on in this thread here's what I'd suggest.

Do this on backup
At first add this line at the top of Module 4 above line Function IsFileOpen(FileName As String). This is a public variable which we will be using across modules.
Code:
Public strWorkbook As String

Then change TestFileOpen sub routine in Module 4 as below:
Code:
Sub TestFileOpen()
strWorkbook = ThisWorkbook.Sheets(1).Range("M1").Value
  If Not IsFileOpen(strWorkbook) Then
  Workbooks.Open strWorkbook
  End If
End Sub

Once you finish these updates then change the UpdateDataMacro2 as below:
Code:
Sub UpdateDataMacro2()
Dim wbDest As Workbook, wbSrc As Workbook
Dim wsSrc As Worksheet
Dim rFind As Range
Dim strSrc As String
Set wbDest = ActiveWorkbook
'======================
'Call macro to UnZip file
UnZipMe
'======================
'function call to test if file is already open

'Here we check for the desired workbook and set it as the source TestFileOpen
On Error Resume Next
strSrc = Mid(strWorkbook, InStrRev(strWorkbook, Application.PathSeparator) + 1, 199)
Set wbSrc = Workbooks(strSrc)
On Error GoTo 0
If wbSrc Is Nothing Then MsgBox "Source workbook not open!", vbInformation: Exit Sub

Set wsSrc = wbSrc.Sheets(1)
For I = 1 To wbDest.Sheets.Count
  
  '===================
  Set rFind = wsSrc.Cells.Find(What:=wbDest.Sheets(I).Cells(1, 1).Value, After _
  :=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows _
  , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
  
  'If Not rFindD Is Nothing Then
  'If wsSrc.Range("C" & rFindT.Row).Value <> wbDest.Sheets(i).Range("A3").Value Then
  If wbDest.Sheets(I).Range("A3") = wsSrc.Range("C" & rFind.Row).Value Then
  'do nothing
  ' MsgBox "Record for date: " & Sheets(i).Range("A3").Text & " already updated!", vbInformation
  MsgBox "Record for lagest date already updated!", vbInformation
  Else
  wbDest.Sheets(I).Rows("3:3").Insert xlDown
  wsSrc.Range("C" & rFind.Row).Copy Destination:=wbDest.Sheets(I).Range("A3")
  wsSrc.Range("H" & rFind.Row & ":J" & rFind.Row).Copy Destination:=wbDest.Sheets(I).Range("B3")
  wsSrc.Range("L" & rFind.Row & ":M" & rFind.Row).Copy Destination:=wbDest.Sheets(I).Range("E3")
  wsSrc.Range("P" & rFind.Row & ":Q" & rFind.Row).Copy Destination:=wbDest.Sheets(I).Range("G3")
  'Else
  'MsgBox "Record for date :" & Sheets(i).Range("A3").Text & " already updated!", vbInformation
  'MsgBox "Update for date :" & Sheets(i).Range("A3").Text & " done!", vbInformation
  'End If
  End If
  'MsgBox "Update for date :" & Sheets(i).Range("A3").Text & " done!", vbInformation
Next I

wbSrc.Close

End Sub

Let us know if this is what you were after.
Thanks Shrivallabha, taking time during busy time of Dewali.
As per your instructions tried but it gives message source workbook is not open, even I had source book open manually and still gives same message.
Whenever, you get time to figure out what is wrong.
Attached is my file.

Thanks,

Ria
 

Attachments

  • COT_DATA.xls
    589 KB · Views: 2
Hi Ria,
At first try adding this call which was missing in the code I posted. Sorry about that.
Code:
On Error Resume Next
strSrc = Mid(strWorkbook, InStrRev(strWorkbook, Application.PathSeparator) + 1, 199)
Set wbSrc = Workbooks(strSrc)
On Error GoTo 0
to
Code:
On Error Resume Next
TestFileOpen 'This call was missing
strSrc = Mid(strWorkbook, InStrRev(strWorkbook, Application.PathSeparator) + 1, 199)
Set wbSrc = Workbooks(strSrc)
On Error GoTo 0
 
  • Like
Reactions: Ria
EXCELLENT and GREAT.
Thanks Shrivallabha.
I already figured out and same time you posted solution.
I really appreciate your help especially during your off time for Dewali.
I hope there will be no more problem/question related to this topic.

Regards

Ria
 
Back
Top