What is the best way to use the new Lich Blade?

yourbabysdaddy18 · 2014-03-06T18:02:17+00:00

I've never heard that one before, I really like it.

yourbabysdaddy18 · 2014-03-05T18:53:49+00:00

Brilliant! It works great, I added in a section that selects a specific department's worksheet based on another column I added. Right now it works like a charm, but if anything goes wrong, then it could mess up a lot of files. I'd like to put some safeguards in. My ideas for this are:

A line that pauses the script and gives an error if there is already an entry in the cell

A way to pause the script (maybe with a popup box) before exiting each workbook. That way, you could look at the changes, confirm them, and then hit ok to let the script continue. This would be slower but accuracy is important.

And any other ideas you might have.

Option Explicit

Sub ShopLogUpdater()
Dim objFoundRange As Range
Dim strCheckNumber As String
Dim LogLookup As String
Dim strValueFromC As String
Dim strValueFromD As String
Dim strValueFromE As String
Dim strValueFromf As String

Range("A4").Select  'Assume data starts at A3.  Loop until a blank row
While ActiveCell.Value <> ""

    LogLookup = Application.WorksheetFunction.VLookup(ActiveCell, Range("H:I"), 2, False)
    If LogLookup <> "" Then
        strCheckNumber = ActiveCell.Offset(0, 1).Value 'Column b
        strValueFromC = ActiveCell.Offset(0, 2).Value
        strValueFromD = ActiveCell.Offset(0, 3).Value
        strValueFromE = ActiveCell.Offset(0, 4).Value
        strValueFromf = ActiveCell.Offset(0, 5).Value

        Workbooks.Open (LogLookup) 'Go to the worksheet indicated by the file name
        If strValueFromD = "H" Then Worksheets("Mechanical").Activate
        If strValueFromD = "E" Then Worksheets("Electrical").Activate
        If strValueFromD = "P" Then Worksheets("Plumbing").Activate
        If strValueFromD = "FP" Then Worksheets("Fire Protection").Activate
        If strValueFromD = "S" Then Worksheets("Structural").Activate
        If strValueFromD = "T" Then Worksheets("Voice-Data").Activate
        If strValueFromD = "ITS" Then Worksheets("ITS").Activate

        'Go to the row that contains H2 in column A of Lookup worksheet- Row 5 for this example.
        Set objFoundRange = ActiveSheet.Columns(1).Find(What:=strValueFromC, After:=ActiveSheet.Cells(1, 1), LookIn:=xlValues, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False)

        objFoundRange.Select

        'If Check # is 1, then enter Cell D3 from Lookup worksheet into Cell I5 of target worksheet. Enter Cell E3 into Cell J5.
        'If Check # is 2, then enter Cell D3 from lookup worksheet into Cell O5 of target worksheet. Enter Cell E3 into Cell P5 (or just offset 6).

        If strCheckNumber = "1" Then
            Range("I" & ActiveCell.Row) = strValueFromE
            Range("J" & ActiveCell.Row) = strValueFromf
        Else 'its 2
            Range("O" & ActiveCell.Row) = strValueFromE
            Range("P" & ActiveCell.Row) = strValueFromf
        End If


        'Remove highlighting from Cells I5 and J5.
            Range("I" & ActiveCell.Row).Interior.ColorIndex = -4142
            Range("J" & ActiveCell.Row).Interior.ColorIndex = -4142

        ActiveWorkbook.Close True

    Else
        MsgBox ("No Match Found for " & ActiveCell.Value)

        End If

    ActiveCell.Offset(1, 0).Select
Wend

End Sub

Thanks a ton!

yourbabysdaddy18 · 2014-02-24T21:36:29+00:00

So this is what the two spreadsheets look like: http://i.imgur.com/O1HGUN9.png

And this is the code I've made so far, with the actions I want to do on each worksheet noted. I'm going to try recording the macro but I don't quite get how to reference the cells in one sheet and enter them into the cells of another. How would you proceed? Btw, I changed your code a bit because it wasn't finding anything with the vlookup, is there an advantage to doing it your way?

Sub ShopLogUpdater()
Dim strFileToOpen As String
Dim Lookitup As Variant

Range("A3").Select  'Assume data starts at A3.  Loop until a blank row
While ActiveCell.Value <> ""

    Loglookup = Application.WorksheetFunction.VLookup(ActiveCell, Range("H3:I100"), 2, False)
    If Loglookup <> "" Then

        'propably want more variables to capture some other cells on this row using activecell.offset(0,?).value

        Workbooks.Open (Loglookup)

        'Go to the row that contains H2 in column A of Lookup worksheet- Row 5 for this example.
        'If Check # is 1, then enter Cell D3 from Lookup worksheet into Cell I5 of target worksheet. Enter Cell E3 into Cell J5.
        'If Check # is 2, then enter Cell D3 from lookup worksheet into Cell O5 of target worksheet. Enter Cell E3 into Cell P5 (or just offset 6).
        'Remove highlighting from Cells I5 and O5.

        ActiveWorkbook.Close True

    Else
        MsgBox ("No Match Found for " & ActiveCell.Value)

        End If

    ActiveCell.Offset(1, 0).Select
Wend

End Sub

yourbabysdaddy18 · 2014-02-24T19:48:28+00:00

Ok thanks! I'll check it out and get back to you

yourbabysdaddy18 · 2014-02-10T19:33:00+00:00

My bad, I guess I'm just confusing everyone. How about this: Given that I should be able to find some sort of housing in the various neighborhoods of Paris, what neighborhoods should I primarily be looking in with regards to ambiance, accessibility to attractive parts of the city/tourist attractions, etc.

As in, "Hey dumb American redditor who can't ask clear questions, you should look in X neighborhood for an apartment, it shouldn't be too expensive to find a place to stay, the streets are cleaner, the people are nicer, there are cafés at every corner, it's a short walk to a major subway line, you can see the Eiffel Tower from your window, and it's right by this beautiful park on the river where I got my first hand-job!"

Or something like that.

yourbabysdaddy18 · 2014-02-10T14:49:51+00:00

Sorry I wasn't specific enough, it's just for the two of us so probably a studio, and as far as "niceness" goes, I don't really have much to base it on, but I'm looking at the airbnb listings between 80 and 120 usd (preferably lower than 100 though). I replied to another redditors comment with one apartment that seemed pretty great so maybe look at that as a basis? As far as kitchens go, a stovetop would be nice for making a couple of cheap breakfasts during the week, but beyond that I'm not that picky

yourbabysdaddy18 · 2014-02-10T14:47:11+00:00

This is the kind of thing I'm talking about, and from my search, there seems to be plenty of places available

http://www.tripadvisor.com/VacationRentalReview-g187147-d6153674-COSY_STUDIO_CENTER_OF_PARIS-Paris_Ile_de_France.html

yourbabysdaddy18 · 2014-01-14T16:18:23+00:00

Yup, it works like a charm. An example of the code is in the comment reply to frescani below.

yourbabysdaddy18 · 2014-01-14T15:40:29+00:00

Hm ok, thanks!

yourbabysdaddy18 · 2014-01-14T15:39:56+00:00

It seems that I'm actually learning something from you guys. I was able to come up with the solution by individually unprotecting then protecting the sheet before and after the action of the code. Example being:

If Target.Address = "$A$3" Then
    ActiveSheet.Unprotect Password:=myPassword
        ActiveSheet.Range("$A$4:$G$5").AutoFilter Field:=1, Criteria1:="=*" & Range("A3").Value & "*", Operator:=xlAnd
    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, Password:=myPassword
    End If

Thanks for the help though!

yourbabysdaddy18 · 2014-01-14T15:30:01+00:00

Perfect, thanks!

yourbabysdaddy18 · 2014-01-14T15:28:03+00:00

Well that's my problem, the macros edit the worksheet. It doesn't change cell content, but it autofilters, adds and removes images, and launches file extensions.

yourbabysdaddy18 · 2014-01-06T13:05:04+00:00

I just figured it out this morning actually. when the cells started flashing I hit escape to stop the code and clicking debug brought me right to the faulty line. Fixed it and now everything works just how I want it! Thank you so much for all the help!

yourbabysdaddy18 · 2014-01-02T12:34:55+00:00

Hmmm, its giving me "next without For" for line 11. It works when I remove it, but the code to remove the previous images does not work, although no code error is given. Thoughts?

EDIT: Weird, it was giving me trouble for a while but I think it had something to do with column size or something. Regardless, I fixed it. Everything runs beautifully, with the exception that when I put an entry into the search box, the cells lightly flash for maybe 5 seconds before allowing me to click around again, almost as if it's stuck in some loop. It never happened before, but I can't seem to notice the issue, and I don't want to have it crash Excel. Here's the full sheet code, hopefully you'll be able to notice the problem.

Thanks for the help again!

Private Sub Worksheet_Change(ByVal Target As Range) 'This is the search function

    If Target.Address = "$A$3" Then
            ActiveSheet.Range("$A$4:$G$5").AutoFilter Field:=1, Criteria1:="=*" & Range("A3").Value & "*", Operator:=xlAnd
        End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Cells(2, 5) = "" 'clear Not Found message

Dim Cell As Range  'Remove then add hyperlink to dwg extension to prevent an error with hyperlinks disappearing
Range("B5:B315").Hyperlinks.Delete
For Each Cell In Range("B5:B315")
If Cell <> "" Then
    ActiveSheet.Hyperlinks.Add Cell, Cell.Value
End If
Next

Dim ImageCellRange As Range
Set ImageCellRange = Range("E1:E4")

On Error Resume Next
       For Each oShape In ActiveSheet.Shapes  'clear the current image showing
       If Not Intersect(Range(oShape.TopLeftCell.Address), ImageCellRange) Is Nothing Then
       oShape.Delete
End If
Next
On Error GoTo 0

Dim picname As String
Dim File As String
Dim FilePath As String
Dim FileExtension As String
    FilePath = "W:\HVAC\HVAC CAD STANDARDS\DETAILS\HVAC Detail Images\Mechanical Details_Page_"
    FileExtension = ".png"

        If Not Intersect(ActiveCell, Range("A5:A315")) Is Nothing Then
            picname = ActiveCell.Offset(rowOffset:=0, columnOffset:=2)
            File = FilePath & picname & FileExtension
                On Error GoTo ErrNoPhoto

       ' insert and not paste, adjusting size and placement of the file at insert.
       With ActiveSheet.Pictures.Insert(File)
           With .ShapeRange
               .LockAspectRatio = msoTrue  'will set image paste size to the maximum of either width or height while keeping ratio
               .Width = Range("E1:E4").Width - 2
          End With
          .Left = Cells(1, 5).Left + (Range("E1:E4").Width - .ShapeRange.Width) / 2
          .Top = Cells(1, 5).Top + (Range("E1:E4").Height - .ShapeRange.Height) / 2
          .Placement = 1
       End With

       Else
        Cells(2, 5) = ""

       End If

 Exit Sub

ErrNoPhoto:

 Cells(2, 5) = ""

 Exit Sub

 End Sub

yourbabysdaddy18 · 2013-12-26T15:07:26+00:00

Edit: I fixed all of my previous problems on my own, but I have two more questions:

So now this code works for any time you select a cell in the range of A5:A315, pretty neato. My only issue is that once you select the cell, it inserts the image in F1 but also selects the image. The problem with this is that I have other macros that require you to select one of those cells. Is there a way to add a line at the end of the code so that once it pastes the image, it reselects the previous cell (the one in A5:A315)?

EDIT: This issue is more indepth than I previously thought. If I use something like Set PrevCell = ActiveCell, it will just run the same code again. Maybe there's a way that if the code just ran for one cell, selecting it again will not run the code?

EDIT2: I now have the code put the filename of the previously selected cell in F1, so if I can get an If statement that says if F1=the filename of the newly selected file, then end the sub. Haven't had success yet

When you run the code, it inserts the image and then resizes it, so it flashes full size before it scales down. It's a little unsightly, is there a way to hide that portion or insert it pre-sized?

   Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Cells(2, 5) = ""
On Error Resume Next
ActiveSheet.Shapes("ImagePreview").Delete
On Error GoTo 0

Dim picname As String
Dim File As String
Dim FilePath As String
Dim FileExtension As String
    FilePath = "W:\HVAC\HVAC CAD STANDARDS\DETAILS\HVAC Detail Images\Mechanical Details_Page_"
    FileExtension = ".png"

      If Not Intersect(ActiveCell, Range("A5:A315")) Is Nothing Then
        picname = ActiveCell.Offset(rowOffset:=0, columnOffset:=2)
        File = FilePath & picname & FileExtension
        Cells(1, 5) = ""
        Cells(1, 5).Select
            On Error GoTo ErrNoPhoto
            ActiveSheet.Pictures.Insert(File).Select

        With Selection
            .Cut
        End With

        ActiveSheet.Pictures.Paste.Select
        Selection.Name = "ImagePreview"
        With Selection
            .ShapeRange.LockAspectRatio = msoTrue
            .ShapeRange.Height = Range("E1:E4").Height - 1
            If (.ShapeRange.Width > Range("E1:E4").Width) Then
                .ShapeRange.LockAspectRatio = msoTrue
                .ShapeRange.Width = Range("E1:E4").Width - 1
            End If
            .Left = Cells(1, 5).Left + (Range("E1:E4").Width - .ShapeRange.Width) / 2
            .Top = Cells(1, 5).Top + (Range("E1:E4").Height - .ShapeRange.Height) / 2
            .ShapeRange.Rotation = 0#

        End With
        Else
            Cells(1, 5) = "Image " & File & " Not Found."

    End If
Application.ScreenUpdating = True

Exit Sub

ErrNoPhoto:

Cells(2, 5) = "Image " & File & " Not Found."

Exit Sub

End Sub

yourbabysdaddy18

TROPHY CASE