• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 228
  • Last Modified:

Macro enhancement to control output data

I received help with developing this macro from dlmille (Dave). I now need for the macro to only populate data if the data is not already present. The field D, "Reconstruction ID". If that data is present then the routine to move the data can be skipped, read the next record, check it etc. Attached is the excel spreadsheet output with some results already populated plus a folder with input files. The spreadsheet macro reads through each file in the folder an populates every line with a record. Now it needs to begin populating after the last record with new records. Thanks for your help and let me know if you have questions. Janis
  • 2
1 Solution
As requested, added all the existing reconstruction id's to a dictionary (which can only hold unique values), then as workbooks are processed, the id is tested and skipped if a match is found.  The use of dictionary is a VERY FAST way to compare an item with a collection.

For more on the Dictionary Class (I use it more and more) see matthewspatrick's great article on the subject:

Here's the revised code in the main routine:
Sub ProcessFilesInFolder()

Dim dstWkb As Workbook
Dim dstSht As Worksheet
Dim srcWkb As Workbook
Dim srcSht As Workbook
Dim dirResult As String
Dim fName As String
Dim fpathName As String
Dim rDest As Range
Dim myDict As Object 'Dictionary holding unique reconstruction ID's
Dim xMsg As Long

    Application.ScreenUpdating = False

    'Setup variables for this workbook and destination worksheets

    Set dstWkb = ThisWorkbook
    Set dstSht = dstWkb.Sheets("Data_Pull")
    Set myDict = CreateObject("Scripting.Dictionary")
    'load existing reconstruction ID's into dictionary
    For Each r In dstSht.Range("D7", dstSht.Range("D" & dstSht.Rows.Count).End(xlUp))
        If Not myDict.exists(r.Value) Then
            myDict.Add r.Value, Nothing
        ElseIf xMsg <> vbYes Then 'if already asked then don't prompt again
            xMsg = MsgBox("You already have duplicate reconstruction ID's in the source sheet (" & r.Value & ")", vbYesNo, "Continue Anyway (YES), Abort (NO)")
            If xMsg = vbNo Then GoTo gracefulExit
        End If
    Next r
    'prompt user for directory from which to find import workbooks.
    'Assumes all workbooks are .xlsx and no other workbooks exist (or change filter criteria)

    dirResult = browseForFolder(ThisWorkbook.Path & "\", "Select Path for Import Files")
    'dirResult = "C:\Users\jketcher\Documents\Janis Folder November 6\MCU\MCU_Workbooks_Mid_Format"

    If dirResult <> "" Then

        'Process all files in folder
        fName = Dir(dirResult & "\*")
        'fName = Dir(dirResult & "\*.xlsx")
        'fetch first file in folder meeting this criteria

        If fName <> "" Then
            On Error Resume Next    'need to do error checking to ensure successful file open on every file

                Application.StatusBar = "Processing file: " & fName
                fpathName = dirResult & "\" & fName
                Set srcWkb = Workbooks.Open(Filename:=fpathName, UpdateLinks:=False, ReadOnly:=True)

                If Not srcWkb Is Nothing Then
                    'establish row to populate for all 3 macros
                    Set rDest = dstSht.Range("A" & dstSht.Rows.Count).End(xlUp).Offset(1, 0)
                    If rDest.Row < 7 Then
                        Set rDest = dstSht.Range("A7")
                    End If
                    'check to see if the Reconstruction ID already exists
                    If Not myDict.exists(srcWkb.Sheets("Courses").Range("B4").Value) Then
                        Call DataTransfer(srcWkb, rDest)
                        Call DataTransfer2(srcWkb, rDest)
                        Call DataTransfer3(srcWkb, rDest)
                    End If
                    srcWkb.Close savechanges:=False
                End If

                fName = Dir    'Get Next File
            Loop Until fName = ""
        End If
    End If

    Set myDict = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

Open in new window

See attached demonstration workbook.

DMKetcherAuthor Commented:
Thanks so much. I will work on it today and get back to you. I appreciate the educational tips.

DMKetcherAuthor Commented:
Thanks so much!

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now