+ Reply to Thread
Results 1 to 3 of 3

Complicated look up macro possible?

Hybrid View

  1. #1
    Registered User
    Join Date
    06-25-2012
    Location
    Los Angeles, California
    MS-Off Ver
    Excel 2010
    Posts
    2

    Complicated look up macro possible?

    Good day everyone

    I have been working with excel for a long time, but I am fairly new to making clean, good macros. The macro I am trying to make right now needs to be usable by multiple people whom have varying skill levels with excel, which is making this more difficult for me.

    Here is what I need the macro to do.

    I want to combine multiple excel files into a spreadsheet on sheet 2 and then use a lookup to get values from sheet 2 and put them on sheet 1. The problem is that I cannot use a simple vlookup because I need to look up based on 2 values.

    Right now I have a macro that is combining multiple excel files into a single sheet and then deleting any blank rows.

    Here is the macro:

    Private Declare Function SetCurrentDirectoryA Lib _
    "kernel32" (ByVal lpPathName As String) As Long
    Sub ChDirNet(szPath As String)
    SetCurrentDirectoryA szPath
    End Sub
    Sub Combine_Workbooks_Select_Files()
    Dim MyPath As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant
    With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    End With
    SaveDriveDir = CurDir
    ChDirNet "C:\Libraries\Documents"
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
    MultiSelect:=True)
    If IsArray(FName) Then
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1
    For Fnum = LBound(FName) To UBound(FName)
    Set mybook = Nothing
    On Error Resume Next
    Set mybook = Workbooks.Open(FName(Fnum))
    On Error GoTo 0
    If Not mybook Is Nothing Then
    On Error Resume Next
    With mybook.Worksheets(1)
    Set sourceRange = .Range("A2:Q100")
    End With
    If Err.Number > 0 Then
    Err.Clear
    Set sourceRange = Nothing
    Else
    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
    Set sourceRange = Nothing
    End If
    End If
    On Error GoTo 0
    If Not sourceRange Is Nothing Then
    SourceRcount = sourceRange.Rows.Count
    If rnum + SourceRcount >= BaseWks.Rows.Count Then
    MsgBox "Not enough rows in the sheet. "
    BaseWks.Columns.AutoFit
    mybook.Close savechanges:=False
    GoTo ExitTheSub
    Else
    Set destrange = BaseWks.Range("A" & rnum)
    With sourceRange
    Set destrange = destrange. _
    Resize(.Rows.Count, .Columns.Count)
    End With
    destrange.Value = sourceRange.Value
    rnum = rnum + SourceRcount
    End If
    End If
    mybook.Close savechanges:=False
    End If
    Next Fnum
    BaseWks.Columns.AutoFit
    End If
    ExitTheSub: 
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
    End With
    ChDirNet SaveDriveDir
    Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End Sub
    I realize this macro uses sheet 1 and needs to be altered some to use sheet 2. I also realize that the current macro only looks for the first 100 rows to compile, I don't know how to make it look for all the information regardless of how many rows it may be.

    I am learning by doing

    So the table on sheet 1 has 17 columns and a varying number of rows, the files I am combining for sheet 2 will only have 15 columns, but also have varying number of rows.

    Once the files are compiled onto sheet 2 I want to look up based on values in Column B (warehouse) and column F (item number). I can't just look up by item number because the item numbers exist in multiple warehouses. Once I have looked up the correct row using Col B and F, I want to take the information from Column N and Column O on sheet 2 (the compiled list) and put it into the same columns on sheet 1.

    Once I have all of the values from sheet 2 on sheet 1, I don't need to use sheet 2 anymore, but I do need to do some additional formatting to sheet 1, which I know can be macro'd into the end of the lookup macro.

    The formatting section:

    I need to check the value in column N compare it to column L to test if the values are equal and if they are NOT equal to format the cell in column N to be filled green. If column L is blank, compare it to column K, and if column K is also blank compare it to column J, but to not compare all 3... only go to the next cell if the first check and/or second check are blank.

    Then if the values are not equal (thus making the cell green) I need the macro to to put a "Y" in column P if the value in N is green because it is LESS THAN the checked cells.

    There is one last thing I'd like to add to the macro, but I'm not sure if it's possible. Column O is a comments column. I'd like the macro to add the current date to the end of any cell that is not blank. So if the cell is blank it would enter nothing, but if the cell says "Lack of materials" or anything else I'd like it to alter the cell to say "Lack of Materials 5/28/12" or whatever happens to be the current date.

    As I mentioned before the most difficult thing for me is to make this macro usable by several people of varying skills with excel. I need to make it a template so people can put their list in to sheet 1 and then run the macro, tell it which files to compile, and then the macro do the rest of the work for them, without them having to change variables or tinker with the macro (which is what I would normally do if something went wrong).

    I appreciate any advice you can give me, I'm trying hard to learn as much as I can about VBA and macros in excel so that I can make more macros in the future that are usable by anyone.

    Thank you very much!!!

  2. #2
    Registered User
    Join Date
    06-25-2012
    Location
    Los Angeles, California
    MS-Off Ver
    Excel 2010
    Posts
    2

    Re: Complicated look up macro possible?

    No one has any ideas?

  3. #3
    Forum Moderator Leith Ross's Avatar
    Join Date
    01-15-2005
    Location
    San Francisco, Ca
    MS-Off Ver
    2000, 2003, & 2010
    Posts
    23,258

    Re: Complicated look up macro possible?

    Hello TavisB,

    I currently have a copy of your workbook open. The extent of my work on it has been indenting the code to make it readable. Here is the result so far.
    
    Private Declare Function SetCurrentDirectoryA _
        Lib "kernel32.dll" _
            (ByVal lpPathName As String) _
        As Long
    
    Sub ChDirNet(szPath As String)
        SetCurrentDirectoryA szPath
    End Sub
    
    Sub Combine_Workbooks_Select_Files()
    
        Dim MyPath As String
        Dim SourceRcount As Long, Fnum As Long
        Dim mybook As Workbook, BaseWks As Worksheet
        Dim sourceRange As Range, destrange As Range
        Dim rnum As Long, CalcMode As Long
        Dim SaveDriveDir As String
        Dim FName As Variant
        
            With Application
                CalcMode = .Calculation
                .Calculation = xlCalculationManual
                .ScreenUpdating = False
                .EnableEvents = False
            End With
            
            SaveDriveDir = CurDir
            ChDirNet "C:\Libraries\Documents"
            
            FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
            
                If IsArray(FName) Then
                    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
                    rnum = 1
                        For Fnum = LBound(FName) To UBound(FName)
                            Set mybook = Nothing
                            On Error Resume Next
                                Set mybook = Workbooks.Open(FName(Fnum))
                            On Error GoTo 0
                            
                            If Not mybook Is Nothing Then
                                On Error Resume Next
                                With mybook.Worksheets(1)
                                    Set sourceRange = .Range("A2:Q100")
                                End With
                                If Err.Number > 0 Then
                                    Err.Clear
                                    Set sourceRange = Nothing
                                Else
                                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                                        Set sourceRange = Nothing
                                    End If
                                End If
                                On Error GoTo 0
                                
                                If Not sourceRange Is Nothing Then
                                    SourceRcount = sourceRange.Rows.Count
                                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                                        MsgBox "Not enough rows in the sheet. "
                                        BaseWks.Columns.AutoFit
                                        mybook.Close savechanges:=False
                                        GoTo ExitTheSub
                                    Else
                                        Set destrange = BaseWks.Range("A" & rnum)
                                            With sourceRange
                                                Set destrange = destrange.Resize(.Rows.Count, .Columns.Count)
                                            End With
                                        destrange.Value = sourceRange.Value
                                        rnum = rnum + SourceRcount
                                    End If
                                End If
                                
                                mybook.Close savechanges:=False
                            End If
                        Next Fnum
                        
                    BaseWks.Columns.AutoFit
                End If
    
    ExitTheSub:
            With Application
                .ScreenUpdating = True
                .EnableEvents = True
                .Calculation = CalcMode
            End With
            
            ChDirNet SaveDriveDir
            Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            
    End Sub
    You should add formatting code to your list of things to do to make macros "clean". It will save you and others time in understanding and maintaining the code. Comments is also another thing to add to the list.
    Sincerely,
    Leith Ross

    Remember To Do the Following....

    1. Use code tags. Place [CODE] before the first line of code and [/CODE] after the last line of code.
    2. Thank those who have helped you by clicking the Star below the post.
    3. Please mark your post [SOLVED] if it has been answered satisfactorily.


    Old Scottish Proverb...
    Luathaid gu deanamh maille! (Rushing causes delays!)

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1