VBA Add error handling to a loop

M

molsonlabatt

New Member
Joined
Jul 25, 2012
Messages
14
My current code opens a file ("Report01.CSV") from the directories in column A (one at a time), and copies data into sheet 2.


The problem is that sometimes there is no ("Report01.CSV") file in one or more of the directories.


What I would like to add is an error handler that would remove the directory (delete that cell) that caused the error and continue with the loop. I.e. resume importing data from the other directories.

Cheers

CODE:
Dim wrkMyWorkBook As Workbook
Dim lngRow As Long: lngRow = 1
Dim lngColumn As Long: lngColumn = 2

Do Until Sheets("Sheet1").Range("A" & lngRow).Value = vbNullString
Set wrkMyWorkBook = Workbooks.Open(Filename:=Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV")
lngRow = lngRow + 1

Windows("REPORT01.CSV").Activate
Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(, -3).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("FID_V1.xls").Activate
Sheets("Sheet2").Select
Cells(2, lngColumn).Select
lngColumn = lngColumn + 1
ActiveSheet.Paste

wrkMyWorkBook.Close SaveChanges:=False
Loop
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
You could use Dir to check if the file exists in the specified path.
Code: 
strPath = Sheets("Sheet1").Range("A" & lngRow).Value

If Len(Dir(strPath & "\REPORT01.CSV")) = 0 Then
    ' file not found in directory
     Sheets("Sheet1").Range("A" & lngRow).Delete xlShiftUp
Else
     Set wrkMyWorkBook = Workbooks.Open(Filename:=Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV")


     wrkMyWorkBook .Sheets(1).Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate

     ActiveCell.Offset(, -3).Select

     Range(Selection, Selection.End(xlDown)).Copy Workbooks("FID_V1.xls").Sheets("Sheet2").Cells(2, lngColumn)

     lngColumn = lngColumn + 1
     lngRow = lngRow + 1
     wrkMyWorkBook.Close SaveChanges:=False

End If
 
Upvote 0
Modifying your code just a little bit should work fine:
Code: 
Dim wrkMyWorkBook As Workbook
Dim lngRow As Long: lngRow = 1
Dim lngColumn As Long: lngColumn = 2


Do Until Sheets("Sheet1").Range("A" & lngRow).Value = vbNullString
   If Dir(Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV") <> "" Then
      Set wrkMyWorkBook = Workbooks.Open(Filename:=Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV")
      lngRow = lngRow + 1
         
      Windows("REPORT01.CSV").Activate
      Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
         LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
         MatchCase:=False, SearchFormat:=False).Activate
      ActiveCell.Offset(, -3).Select
      Range(Selection, Selection.End(xlDown)).Copy
      Windows("FID_V1.xls").Activate
      Sheets("Sheet2").Cells(2, lngColumn).Select
      lngColumn = lngColumn + 1
      ActiveSheet.Paste
      
      wrkMyWorkBook.Close SaveChanges:=False
   
   Else
      Sheets("Sheet1").Cells(lngRow,1).Delete
   End If


Loop
 
Upvote 0
Thanks for the quick repiles, NORIE and Audioa84 . Unfortunately neither solution works. My directory code only pulls out the folder names and does not contain the Report01.CSV extension.

Extension Example: [TABLE="width: 112"]
<tbody>[TR]
[TD]C:\Users\Me\Desktop\FID\FEB06\FEB06-16.D
[/TD]
[/TR]
</tbody>[/TABLE]

Entrie macro code is below.

Thanks for your time and help.

Code that gets my directory (subfolder)
Code: 
Dim FolderName As String
 
    With Application.FileDialog(msoFileDialogFolderPicker)
         .AllowMultiSelect = False
         If .Show = -1 Then
       
            FolderName = .SelectedItems(1)
         End If
     End With
i = 1
LookInTheFolder = FolderName
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
' above open dailog box to select folder and saves directory as folder name
For Each SearchFolders In FileSystemObject.GetFolder(LookInTheFolder).SubFolders
Cells(i, 1) = SearchFolders
i = i + 1

Code for whole macro (if that helps)
Code: 
Sub TestVersion1()
'
' Test version of import loop v2
' Import of files from directory, but includes conversion to ANSI step. This macro requires conversion to ANSI to be performed and be present in the directory.
' Now includes sort of directory by sample number
'
Dim FolderName As String
 
    With Application.FileDialog(msoFileDialogFolderPicker)
         .AllowMultiSelect = False
         If .Show = -1 Then
       
            FolderName = .SelectedItems(1)
         End If
     End With
i = 1
LookInTheFolder = FolderName
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
' above open dailog box to select folder and saves directory as folder name
For Each SearchFolders In FileSystemObject.GetFolder(LookInTheFolder).SubFolders
Cells(i, 1) = SearchFolders
i = i + 1
    
Next SearchFolders
Cells.Find(What:="STDBY", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
    Selection.Delete Shift:=xlUp
    Cells.Find(What:="Conv", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Selection.Delete Shift:=xlUp
' Above finds and deletes STDBY and Conversion directories from list in sheet1
Sheets("Sheet1").Select
Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Texttocolumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True
    'Text to columns of directory
    
   
   Range("A1").End(xlToRight).Offset(, 1).Select
    ActiveCell.FormulaR1C1 = "=VALUE(MID(RC[-1],7,FIND(""."",RC[-1])-6))"
    Dim LR     As Long
    LR = Cells.Find("*", , , , 1, 2).Row
    If Selection(1).Row < LR Then
        Selection.AutoFill Destination:=Selection.Resize(LR - Selection.Row + 1)
    End If
' Adds formula to last coumn + 1 and auto fills down based on number of rows
 
 LastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
 LastCol = ThisWorkbook.Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
' Gets last row number and last column number
Set SortA = ActiveSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))
' Create name for all sort area
   Range("A1").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Worksheets("Sheet1").Cells(1, LastCol), Worksheets("Sheet1").Cells(LastRow, LastCol)), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange SortA
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
' Sort cells by last column
Range("A1").Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
' Selects and deletes sort row befroe formule concontatae step
  Const StartRow As Long = 1
  Delimiter = "\"
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For X = StartRow To LastRow
    LastCol = Cells(X, Columns.Count).End(xlToLeft).Column
    If LastCol = 3 Then
      Cells(X, "B").Value = Cells(X, "C").Value
    Else
      Cells(X, "A").Value = Join(Application.Index(Range(Cells(X, "A"), Cells(X, LastCol)).Value, 1, 0), Delimiter)
    End If
  Next
 'Reverses text to columns
  
  Columns("B:M").Select
Selection.Delete Shift:=xlToLeft
'Deletes left over columns from reverse of text to columns
    
    Dim wrkMyWorkBook As Workbook
    Dim lngRow As Long: lngRow = 1
    Dim lngColumn As Long: lngColumn = 2
    
    Do Until Sheets("Sheet1").Range("A" & lngRow).Value = vbNullString
        Set wrkMyWorkBook = Workbooks.Open(Filename:=Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV")
        lngRow = lngRow + 1
    
        Windows("REPORT01.CSV").Activate
        Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(, -3).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Windows("FID_V1.xls").Activate
        Sheets("Sheet2").Select
        Cells(2, lngColumn).Select
        lngColumn = lngColumn + 1
        ActiveSheet.Paste
        
        wrkMyWorkBook.Close SaveChanges:=False
    Loop

' above loops, opens first directory in list (sheet) and selects file name Report01.csv it opens
' this file and finds Ethylene and copies and paste it data -3 cells over into new sheet. Then closes Report01
Sheets("Sheet1").Select
Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Texttocolumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True
        
' Text to columns of directory to get folder name slhas sample name
Range("A1").Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("B1,B20").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    
' Tranpose samples names on to sheet 2
Range("A1").Select
Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(, 1).Select
        Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Replace What:="-", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "0.00"
    Range("B1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
' Format sheet 2 data for import to HPLC final sheet
End Sub
 
Upvote 0
Can you provide what your data looks like right after
Columns("B:M").Delete Shift:=xlToLeft
Click to expand...
? I've tried out your code and I'm just left with the drive letter in column A when the code is at the point I quoted. I would be happy to help more, but without a better picture of what you are seeing its hard to go further.
 
Upvote 0
Thanks for your help. I am not a programmer. I will try and provide some clarification:
The purpose for above section of code: To load Directory locations for each sample. (e.g. FEB06-2.D) would be one sample. I require the directories (samples) to be in order that they were run (1,2,3,4 etc). This is the reason for the text to columns and sorting. Then the code combines the cells back into a string.

The issue is that within each folder (e.g. FEB06-2.D) the file REPORT01.CSV does not always exist. And my code stops working during the loop.

For example: Say the folder show in column "A1" below does not contain the REPORT file, my code stops working. What I need it to do is: Delete that row and continue on to the next row (A2 in this case) (during the loop). This is important because at the end of my code I copy the sample names and paste them above the imported data.



In column "A" this is what appears after above code:
A1[TABLE="width: 112"]
<tbody>[TR]
[TD]C:\Users\me\Desktop\FID\Newfolder\FEB061\FEB06-2.D
[/TD]
[/TR]
</tbody>[/TABLE]
A2
[TABLE="width: 112"]
<tbody>[TR]
[TD]C:\Users\me\Desktop\FID\New folder\FEB0612\FEB06-3.D
A3
Etc.
Thanks.
[/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:
Upvote 0
OK, so I have run through your code and understand what it intends to do. It works fine for me if I use the code I gave you. What error code is it giving you?


Here is the code that worked for me:
Code: 
Sub TestVersion1()
'
' Test version of import loop v2
' Import of files from directory, but includes conversion to ANSI step. This macro requires conversion to ANSI to be performed and be present in the directory.
' Now includes sort of directory by sample number
'
Dim FolderName As String
Dim LR     As Long
Dim wrkMyWorkBook As Workbook
Dim lngRow As Long: lngRow = 1
Dim lngColumn As Long: lngColumn = 2
 
i = 1
GoTo Start:
' Open dialog box to select folder and saves directory as folder name
With Application.FileDialog(msoFileDialogFolderPicker)
   .AllowMultiSelect = False
   If .Show = -1 Then
 
      FolderName = .SelectedItems(1)
   End If
End With


LookInTheFolder = FolderName
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")


For Each SearchFolders In FileSystemObject.GetFolder(LookInTheFolder).SubFolders
   Cells(i, 1) = SearchFolders
   i = i + 1
Next SearchFolders


' Find and delete STDBY and Conversion directories from list in sheet1
Cells.Find(What:="STDBY", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
   SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Delete Shift:=xlUp


Cells.Find(What:="Conv", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
   SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Delete Shift:=xlUp


Start:
'Text to columns of directory
Sheets("Sheet1").Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
   :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
   1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True


' Adds formula to last column + 1 and auto fills down based on number of rows
Range("A1").End(xlToRight).Offset(, 1).Select
ActiveCell.FormulaR1C1 = "=VALUE(MID(RC[-1],7,FIND(""."",RC[-1])-6))"
LR = Cells.Find("*", , , , 1, 2).Row
If Selection(1).Row < LR Then
   Selection.AutoFill Destination:=Selection.Resize(LR - Selection.Row + 1)
End If


 ' Gets last row number and last column number
LastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
LastCol = ThisWorkbook.Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column


' Create name for all sort area
 Set SortA = ActiveSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))


' Sort cells by last column
Range("A1").Select
 ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Worksheets("Sheet1").Cells(1, LastCol), Worksheets("Sheet1").Cells(LastRow, LastCol)), _
 SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 With ActiveWorkbook.Worksheets("Sheet1").Sort
   .SetRange SortA
   .Header = xlGuess
   .MatchCase = False
   .Orientation = xlTopToBottom
   .SortMethod = xlPinYin
   .Apply
 End With


' Selects and deletes sort row before formula concatenate step
Range("A1").Select
Selection.End(xlToRight).Select
Range(Selection, Selection.End(xlDown)).ClearContents


'Reverses text to columns
Const StartRow As Long = 1
Delimiter = "\"
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For X = StartRow To LastRow
   LastCol = Cells(X, Columns.Count).End(xlToLeft).Column
   If LastCol = 3 Then
      Cells(X, "B").Value = Cells(X, "C").Value
   Else
      Cells(X, "A").Value = Join(Application.Index(Range(Cells(X, "A"), Cells(X, LastCol)).Value, 1, 0), Delimiter)
   End If
Next


'Deletes left over columns from reverse of text to columns
Columns("B:M").Delete Shift:=xlToLeft
   
' Loops, opens first directory in list (sheet) and selects file name Report01.csv it opens
' this file and finds Ethylene and copies and paste it data -3 cells over into new sheet. Then closes Report01
Do Until Sheets("Sheet1").Range("A" & lngRow).Value = vbNullString
   If Dir(Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV") <> "" Then
      Set wrkMyWorkBook = Workbooks.Open(Filename:=Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV")
      lngRow = lngRow + 1
   
      Windows("REPORT01.CSV").Activate
      Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
      LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
      MatchCase:=False, SearchFormat:=False).Activate
      ActiveCell.Offset(, -3).Select
      Range(Selection, Selection.End(xlDown)).Select
      Selection.Copy
      Windows("FID_V1.xls").Activate
      Sheets("Sheet2").Select
      Cells(2, lngColumn).Select
      lngColumn = lngColumn + 1
      ActiveSheet.Paste
   
      wrkMyWorkBook.Close SaveChanges:=False
   Else
      Sheets("Sheet1").Cells(lngRow, 1).Delete
   End If
Loop
        
' Text to columns of directory to get folder name slhas sample name
Sheets("Sheet1").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
  Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
  :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
  1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True


' Transpose samples names on to sheet 2
Range("A1").End(xlToRight).Select
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Sheet2").Range("B1,B20").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    


' Format sheet 2 data for import to HPLC final sheet
Range("A1").Select
Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(, 1).Select
        Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Replace What:="-", Replacement:="0", LookAt:=xlPart, SearchOrder:=xlByRows, _
   MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
End Sub
 
Upvote 0
Hi,

After uploading your code it seems to work with a little modification. I removed Goto Start and start lines, since it was giving me a run time error. It was skipping the import of the file directories and trying to text to columns nothing.

One more issue is that (I added this in after I sent you the code) I would like the program during the loop or right before to copy and past the compounds list on A2 of Sheet 2. It is located in the REPORT01.CSV file. I added the code below (in BOLD). I know i can add it two the loop, but there is no need to have it copy the same information evry time and slow down the macro.

Thanks again

Code: 
Public Sub mrexceltest1()
'
' Test version of import loop v2
' Import of files from directory, but includes conversion to ANSI step. This macro requires conversion to ANSI to be performed and be present in the directory.
' Now includes sort of directory by sample number
'
Dim FolderName As String
Dim LR     As Long
Dim wrkmyworkbook As Workbook
Dim lngRow As Long: lngRow = 1
Dim lngColumn As Long: lngColumn = 2
 
i = 1
' Open dialog box to select folder and saves directory as folder name
With Application.FileDialog(msoFileDialogFolderPicker)
   .AllowMultiSelect = False
   If .Show = -1 Then
 
      FolderName = .SelectedItems(1)
   End If
End With

LookInTheFolder = FolderName
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")

For Each SearchFolders In FileSystemObject.GetFolder(LookInTheFolder).SubFolders
   Cells(i, 1) = SearchFolders
   i = i + 1
Next SearchFolders

' Find and delete STDBY and Conversion directories from list in sheet1
Cells.Find(What:="STDBY", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
   SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Delete Shift:=xlUp

Cells.Find(What:="Conv", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
   SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Delete Shift:=xlUp
 
'Text to columns of directory
Sheets("Sheet1").Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
   :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
   1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True

' Adds formula to last column + 1 and auto fills down based on number of rows
Range("A1").End(xlToRight).Offset(, 1).Select
ActiveCell.FormulaR1C1 = "=VALUE(MID(RC[-1],7,FIND(""."",RC[-1])-6))"
LR = Cells.Find("*", , , , 1, 2).Row
If Selection(1).Row < LR Then
   Selection.AutoFill Destination:=Selection.Resize(LR - Selection.Row + 1)
End If

 ' Gets last row number and last column number
LastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
LastCol = ThisWorkbook.Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column

' Create name for all sort area
 Set SortA = ActiveSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))

' Sort cells by last column
Range("A1").Select
 ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Worksheets("Sheet1").Cells(1, LastCol), Worksheets("Sheet1").Cells(LastRow, LastCol)), _
 SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 With ActiveWorkbook.Worksheets("Sheet1").Sort
   .SetRange SortA
   .Header = xlGuess
   .MatchCase = False
   .Orientation = xlTopToBottom
   .SortMethod = xlPinYin
   .Apply
 End With

' Selects and deletes sort row before formula concatenate step
Range("A1").Select
Selection.End(xlToRight).Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Reverses text to columns
Const StartRow As Long = 1
Delimiter = "\"
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For X = StartRow To LastRow
   LastCol = Cells(X, Columns.Count).End(xlToLeft).Column
   If LastCol = 3 Then
      Cells(X, "B").Value = Cells(X, "C").Value
   Else
      Cells(X, "A").Value = Join(Application.Index(Range(Cells(X, "A"), Cells(X, LastCol)).Value, 1, 0), Delimiter)
   End If
Next

'Deletes left over columns from reverse of text to columns
Columns("B:M").Delete Shift:=xlToLeft
   
 [B]Set wrkmyworkbook = Workbooks.Open(Filename:=Sheets("Sheet1").Range("A1").Value & "\" & "REPORT01.CSV")
'Gives error here Run time 1004 cannot find    
 
        Windows("REPORT01.CSV").Activate
        Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Windows("FID_V1.xls").Activate
        Sheets("Sheet2").Select
        Cells(2, 1).Select
        ActiveSheet.Paste
        
        wrkmyworkbook.Close SaveChanges:=False[/B]
     ' Adds compund list from first sample to A2 on sheet 2
     
' Loops, opens first directory in list (sheet) and selects file name Report01.csv it opens
' this file and finds Ethylene and copies and paste it data -3 cells over into new sheet. Then closes Report01
Do Until Sheets("Sheet1").Range("A" & lngRow).Value = vbNullString
   If Dir(Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV") <> "" Then
      Set wrkmyworkbook = Workbooks.Open(Filename:=Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV")
      lngRow = lngRow + 1
   
      Windows("REPORT01.CSV").Activate
      Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
      LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
      MatchCase:=False, SearchFormat:=False).Activate
      ActiveCell.Offset(, -3).Select
      Range(Selection, Selection.End(xlDown)).Select
      Selection.Copy
      Windows("FID_V1.xls").Activate
      Sheets("Sheet2").Select
      Cells(2, lngColumn).Select
      lngColumn = lngColumn + 1
      ActiveSheet.Paste
   
      wrkmyworkbook.Close SaveChanges:=False
   Else
      Sheets("Sheet1").Cells(lngRow, 1).Delete
   End If
Loop
        
' Text to columns of directory to get folder name slhas sample name
Sheets("Sheet1").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
  Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
  :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
  1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True

' Transpose samples names on to sheet 2
Range("A1").Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
' Format sheet 2 data for import to HPLC final sheet
Range("A1").Select
Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(, 1).Select
        Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Replace What:="-", Replacement:="0", LookAt:=xlPart, SearchOrder:=xlByRows, _
   MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
End Sub
 
Upvote 0
Sorry about the start tag being left in, I should have removed those before pasting. I believe I have integrated what you want. I added a boolean (TRUE/FALSE value) variable that starts of being set to false. I then added an if statement that checks the value of that variable. If it hasn't copied the compounds before, then the code you added will run. When that happens, the variable is set to true. The next time a report file is loaded, the if statement checks to see if the variable is false, it won't be, so the copying is skipped.

Code: 
Sub TestVersion1()
'
' Test version of import loop v2
' Import of files from directory, but includes conversion to ANSI step. This macro requires conversion to ANSI to be performed and be present in the directory.
' Now includes sort of directory by sample number
'
Dim FolderName As String
Dim LR     As Long
Dim wrkMyWorkBook As Workbook
Dim lngRow As Long: lngRow = 1
Dim lngColumn As Long: lngColumn = 2
Dim compoundsCopied As Boolean: compoundsCopied = False
 
i = 1
' Open dialog box to select folder and saves directory as folder name
With Application.FileDialog(msoFileDialogFolderPicker)
   .AllowMultiSelect = False
   If .Show = -1 Then
 
      FolderName = .SelectedItems(1)
   End If
End With


LookInTheFolder = FolderName
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")


For Each SearchFolders In FileSystemObject.GetFolder(LookInTheFolder).SubFolders
   Cells(i, 1) = SearchFolders
   i = i + 1
Next SearchFolders


' Find and delete STDBY and Conversion directories from list in sheet1
Cells.Find(What:="STDBY", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
   SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Delete Shift:=xlUp


Cells.Find(What:="Conv", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
   SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Delete Shift:=xlUp


'Text to columns of directory
Sheets("Sheet1").Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
   Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
   :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
   1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True


' Adds formula to last column + 1 and auto fills down based on number of rows
Range("A1").End(xlToRight).Offset(, 1).Select
ActiveCell.FormulaR1C1 = "=VALUE(MID(RC[-1],7,FIND(""."",RC[-1])-6))"
LR = Cells.Find("*", , , , 1, 2).Row
If Selection(1).Row < LR Then
   Selection.AutoFill Destination:=Selection.Resize(LR - Selection.Row + 1)
End If


 ' Gets last row number and last column number
LastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
LastCol = ThisWorkbook.Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column


' Create name for all sort area
 Set SortA = ActiveSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))


' Sort cells by last column
Range("A1").Select
 ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Worksheets("Sheet1").Cells(1, LastCol), Worksheets("Sheet1").Cells(LastRow, LastCol)), _
 SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 With ActiveWorkbook.Worksheets("Sheet1").Sort
   .SetRange SortA
   .Header = xlGuess
   .MatchCase = False
   .Orientation = xlTopToBottom
   .SortMethod = xlPinYin
   .Apply
 End With


' Selects and deletes sort row before formula concatenate step
Range("A1").Select
Selection.End(xlToRight).Select
Range(Selection, Selection.End(xlDown)).ClearContents


'Reverses text to columns
Const StartRow As Long = 1
Delimiter = "\"
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For X = StartRow To LastRow
   LastCol = Cells(X, Columns.Count).End(xlToLeft).Column
   If LastCol = 3 Then
      Cells(X, "B").Value = Cells(X, "C").Value
   Else
      Cells(X, "A").Value = Join(Application.Index(Range(Cells(X, "A"), Cells(X, LastCol)).Value, 1, 0), Delimiter)
   End If
Next


'Deletes left over columns from reverse of text to columns
Columns("B:M").Delete Shift:=xlToLeft
   
' Loops, opens first directory in list (sheet) and selects file name Report01.csv it opens
' this file and finds Ethylene and copies and paste it data -3 cells over into new sheet. Then closes Report01
Do Until Sheets("Sheet1").Range("A" & lngRow).Value = vbNullString
   If Dir(Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV") <> "" Then
      Set wrkMyWorkBook = Workbooks.Open(Filename:=Sheets("Sheet1").Range("A" & lngRow).Value & "\" & "REPORT01.CSV")
      lngRow = lngRow + 1
   
      If compoundsCopied = False Then
         Windows("REPORT01.CSV").Activate
         Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
         LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
         MatchCase:=False, SearchFormat:=False).Activate
         Range(Selection, Selection.End(xlDown)).Select
         Selection.Copy
         Windows("FID_V1.xls").Activate
         Sheets("Sheet2").Select
         Cells(2, 1).Select
         ActiveSheet.Paste
         compoundsCopied = True
      End If
      
      Windows("REPORT01.CSV").Activate
      Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
         LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
         MatchCase:=False, SearchFormat:=False).Activate
      ActiveCell.Offset(, -3).Select
      Range(Selection, Selection.End(xlDown)).Copy
      Windows("FID_V1.xls").Activate
      Sheets("Sheet2").Cells(2, lngColumn).Select
      lngColumn = lngColumn + 1
      ActiveSheet.Paste
   
      wrkMyWorkBook.Close SaveChanges:=False
   Else
      Sheets("Sheet1").Cells(lngRow, 1).Delete
   End If
Loop
        
' Text to columns of directory to get folder name slhas sample name
Sheets("Sheet1").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
  Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
  :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
  1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True


' Transpose samples names on to sheet 2
Range("A1").End(xlToRight).Select
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Sheet2").Range("B1,B20").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    


' Format sheet 2 data for import to HPLC final sheet
Range("A1").Select
Cells.Find(What:="Ethylene", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(, 1).Select
        Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Replace What:="-", Replacement:="0", LookAt:=xlPart, SearchOrder:=xlByRows, _
   MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
End Sub
 
Upvote 0
Sweet. That works perfectly for me. Its clear you know what you are doing. I also got it to work, by adding my code after the loop (hack job). But, your way is much better.

Thanks again
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question Question
Macro to Open File and limit selection where files contains "Parts" in C
Replies
4
Views
229
howard
H
SlinkRN
  • Solved
Handling Multiple Errors within one loop
Replies
7
Views
233
SlinkRN
SlinkRN
willow1985
  • Solved
VBA error handling - File already exists in location
Replies
9
Views
907
NateSC
NateSC
willow1985
  • Solved
VBA Run-time error 91 - Object variable or With block variable not set when trying to refresh data/Sleep
Replies
4
Views
244
willow1985
willow1985
D
  • Solved
VBA to copy only matching data from 2 csv workbooks into the "MasterCSV"
2
Replies
18
Views
883
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top