Solved

Macro enhancement to control output data

Posted on 2012-03-22
3
212 Views
Last Modified: 2012-03-26
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
MCU-File-Review-Summary-Detail-N.xlsm
DeRoy--Shelia-P01-3-19-2012-QC.xlsx
Everly--Gloria-P01-2-20-2012-QC.xlsx
Fields-Murphy--Rebecca-P01-3-18-.xlsx
0
Comment
Question by:DMKetcher
  • 2
3 Comments
 
LVL 41

Accepted Solution

by:
dlmille earned 500 total points
ID: 37755945
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:
http://www.experts-exchange.com/searchResults.jsp?searchTerms=matthewspatrick+dictionary&componentHtmlId=basicSearch&searchType=10

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

            Do
                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

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

Open in new window


See attached demonstration workbook.

Dave
MCU-File-Review-Summary-Detail-N.xlsm
0
 

Author Comment

by:DMKetcher
ID: 37756847
Thanks so much. I will work on it today and get back to you. I appreciate the educational tips.

Janis
0
 

Author Closing Comment

by:DMKetcher
ID: 37766087
Thanks so much!
0

Featured Post

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

Load balancing is the method of dividing the total amount of work performed by one computer between two or more computers. Its aim is to get more work done in the same amount of time, ensuring that all the users get served faster.
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

759 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now