Inconsistant Macro

[PeterTaylor]

Dear All,
I am using excel 2007 and vista 64 bit.
I have the follow macro that steps thru a list of excel files appends the first 14 columns of data to a master files then searchs thru the added file adding the data in named columns to the equilvaent columns in the master column ( the column names in each added file are translated to master file coumn names in the master file.

Sub copy_to_master_collar()
    Application.DisplayAlerts = False
    'Application.ScreenUpdating = False
    
    Workbooks.Open Filename:="K:\collars\1AAA_AL_COLLARS.xlsm"
    Workbooks.Open Filename:="K:\Collar_import_log_file.xlsm"
    
    Dim bCol As Integer, myTest As String, strName As String, myTotalRows As Integer, myTotalColumns As Integer, _
        myColumn As Integer, MyRow As Integer, MyRange As Range, mylist As String, myFilename As String, _
        aRow As Integer, TestBlank As Integer, zRow As Integer, _
        ZCol As Integer, myWindowname As String, xRow As Integer, xCol As Integer, myTotalCollarRows As Integer
        
  '**************************
   
            aRow = 2
            zRow = 1
            ZCol = 1
            xRow = 1
            xCol = 1
        Sheets("imports").Select
    ' Start loop
Do
'On Error GoTo 0
    ' Define values to mylist and myFilename for current pass of Do - Loop cycle
        mylist = Cells(aRow, 1).Value
        myFilename = Cells(aRow, 2).Value
        myWindowname = Cells(aRow, 3).Value
    ' check length of current mylist value,for a zero length
        If Len(mylist) = 0 Then
            ' in case of stray blanks in unsorted data, check next 10 rows
                If TestBlank < 10 Then
                    TestBlank = TestBlank + 1
                    ' kick back to loop start
                     GoTo NoError:
        Else
            MsgBox "End of File Encountered The Procedure will now exit"
                'ActiveWorkbook.Save
                'ActiveWorkbook.Close
                Windows("1AAA_AL_COLLARS.xlsm").Activate
                'ActiveWorkbook.Save
                'ActiveWorkbook.Close
            Application.DisplayAlerts = True
            'Application.ScreenUpdating = True
Exit Do

                End If
        End If
        ' a valid entry needed to get here so reset testblank to 0
        TestBlank = 0
        ' for a non zero length value of mylist, report current value to user and attempt to open file
  '************************
                
        Workbooks.Open mylist
        myTotalRows = ActiveSheet.UsedRange.Rows.Count
        myTotalColumns = ActiveSheet.UsedRange.Columns.Count
        'Test if the last row has drill hole data
        
        If Len(Cells(myTotalRows, 16)) = 0 Then
            Rows(myTotalRows).Select
            Selection.Delete Shift:=xlUp
            myTotalRows = myTotalRows - 1
        'Else
            'GoTo Point A
        End If
'Point A:
        'Copy the fist 14 colunms of data to main file
        Range(Cells(2, 1), Cells(myTotalRows, 14)).Select
        Selection.Copy
        Windows("1AAA_AL_COLLARS.xlsm").Activate
        myTotalCollarRows = ActiveSheet.UsedRange.Rows.Count
        myTotalCollarRows = myTotalCollarRows + 1
        'Cells(1, 2).Select
        'Selection.End(xlDown).Select
        
        'MyRow = ActiveCell.Row + 1
        Cells(myTotalCollarRows, 2).Select
        ActiveSheet.Paste
        
        ' copy the rest of the data colunm by colunm to main file
        
        Windows(myWindowname).Activate
        
           bCol = 15
        ' set to run while row 1 not blank
    While Len(Cells(1, bCol)) > 0
        Cells(1, bCol).Select
        myTest = Trim(UCase(ActiveCell.Value))
        
On Error GoTo NomatchSkip1
        'strName = ""
        
        strName = WorksheetFunction.VLookup(myTest, _
                  Workbooks("Collar_import_log_file.xlsm").Worksheets("Lookup").Range("A1:B1368"), 2, False)
        Range(Cells(2, bCol), Cells(myTotalRows, bCol)).Select
        Selection.Copy
        Windows("1AAA_AL_COLLARS.xlsm").Activate
        'Set MyRange = Worksheets("Sheet1").Names(strName).RefersToRange
        Range(strName).Select
        Selection.End(xlDown).Select
        'MyRow = ActiveCell.Row + 1
        myColumn = ActiveCell.Column
        Cells(myTotalCollarRows, myColumn).Select
        ActiveSheet.Paste
        GoTo point1
        'bCol = bCol + 1
        'Windows("1.xlsx").Activate
NomatchSkip1:
Resume point1
point1:
        bCol = bCol + 1
       Windows(myWindowname).Activate
Wend
        ' on exit bCol set ready for the next file
            bCol = 15
           Windows(myWindowname).Activate
           ActiveWorkbook.Close
           Windows("Collar_import_log_file").Activate
           aRow = aRow + 1
           Sheets("Clean imports").Select
           Cells(zRow, 1).Value = mylist
           myTotalRows = myTotalRows - 1
           Cells(zRow, 2).Value = myTotalRows
           zRow = zRow + 1
           Sheets("imports").Select
NoError:
Loop
    
End Sub

There ~2700 files to add to the master file; the macro works fine when I step thru using debug but when I run the macro not only about 10% of the data is appended.
It appears that the macro does not completely the executed each line before moving on to the next. Is there a way to stop this?
Regards
Peter

 

[PeterTaylor]

Dear Norrie,

I have ~2900 files listed in the following workbook

Dim wbImport As Workbook
 Set wbImport = Workbooks.Open(Filename:="K:\Collar_import_log_file.xlsm")

I need to open each file collect the data an copy it to a master file.

Since the format of these files is inconsistent parse the data requires moving back and forward betwen the files. I need help to ensure that excel is always clear which file has the focus. The help you have already given has gone some way to this end but I think that I need to go further. I have put questions in the code blocks and would value your extra comments.

Dim wbOpen As Workbook
Dim wsData As Worksheet
Dim wbCollars As Workbook

 
    Set wbCollars = Workbooks.Open(Filename:="K:\collars\1AAA_AL_COLLARS.xlsm")
        Set wbOpen = Workbooks.Open(mylist)
        Set wsData = wbOpen.Worksheets(1)
        myTotalRows = wsData.UsedRange.Rows.Count
        myTotalColumns = wsData.UsedRange.Columns.Count
        'Test if the last row has drill hole data
        
   '***** This code checks if the last line in wsData is valid & deletes it if it's not . Can I make the "If" condition more specific?
        If Len(Cells(myTotalRows, 16)) = 0 Then
            wsData.Rows(myTotalRows).Select
            Selection.Delete Shift:=xlUp
            myTotalRows = myTotalRows - 1
        'Else
            'GoTo Point A
        End If
'**********************************
'Point A:
        'Copy the fist 14 colunms of data to main file
        wsData.Range(Cells(2, 1), Cells(myTotalRows, 14)).Select

        'Is "Selection.Copy" specific enough?
        
        Selection.Copy
        
       
        myTotalCollarRows = wsCollars.UsedRange.Rows.Count
        myTotalCollarRows = myTotalCollarRows + 1
        
' without the line below the paste does not work can it be revised?
         Windows("1AAA_AL_COLLARS.xlsm").Activate
       
        wsCollars.Cells(myTotalCollarRows, 2).Select
        wsCollars.Paste

Thanks
Peter

 

[Norie]

Peter

I'm sorry but I must be missing something, why would you need to go back and for the between the files/workbooks?

In what way is the data inconsistent?

The only thing that you seem to be checking in the code is one line of data, and then deleting it if needed.

Anyway, I think I can see how to fix the code, basically you need to get rid of Paste and Activate/Select/Selection.

There's also another thing involving Range/Cells that might cause errors.

I'll just post the code I think will work.

If it doesn't work post back and say how. eg wrong data copied, data copied to wrong place, computer blew up.

Dim wbOpen As Workbook
Dim wsData As Worksheet
Dim wbCollars As Workbook
Dim wsData As Worksheet
Dim rngDst As Range
Dim rngSrc As Range
 
    Set wbCollars = Workbooks.Open(Filename:="K:\collars\1AAA_AL_COLLARS.xlsm")
    
    Set wbOpen = Workbooks.Open(mylist)
    
    Set wsData = wbOpen.Worksheets(1)
    
    myTotalRows = wsData.UsedRange.Rows.Count
    
    myTotalColumns = wsData.UsedRange.Columns.Count
    
    'Test if the last row has drill hole data
    '***** This code checks if the last line in wsData is valid & deletes it if it's not .
    ' Can I make the "If" condition more specific?
    
    If Len(wsData.Cells(myTotalRows, 16)) = 0 Then
    
        wsData.Rows(myTotalRows).Delete Shift:=xlUp
        
        myTotalRows = myTotalRows - 1
    End If
 
    ' get the range to copy - the first 14 columns of data in data file
    Set rngSrc = wsData.Range("A2:N:" & myTotalRows)
 
    ' get the range to copy to
    myTotalCollarRows = wsCollars.UsedRange.Rows.Count

    myTotalCollarRows = myTotalCollarRows + 1
 
    Set rngDst = wsData.Cells(myTotalCollarRows, 2)
 
    'copy
    
    rngSrc.Copy rngDst
 
    ' or if it's just values you want use paste special
 
    rngSrc.Copy
 
    rngDst.PasteSpecial xlPasteValues

Just noticed the comment about the IF, what do you mean by more specific?

 

[PeterTaylor]

Dear Norrie,
I think I have gotten to the bottom of the problem. I have Dimmed the row count as an integer (max value 32,767); since the final file will have ~500,000 records I would need the to dim the row count variable as a Long.

Thanks for your help it will allow me to streamline my code in the future.
Regards
Peter

 

[Norie]

Well I'm glad you found a solution.

Mind you I can't recall you mentioning what the problem was, or you did and and I missed it.