Consulting

Results 1 to 3 of 3

Thread: Find & Replace - All worksheets except one and with different Target column

  1. #1
    VBAX Newbie
    Joined
    Sep 2020
    Posts
    2
    Location

    Find & Replace - All worksheets except one and with different Target column

    Hi ALL,

    I have vba code below, stored on Workbook(cs-asmemetric1.xls) that works on a specific worksheet and column. But when I copied this exact code to my Personal.xlsb it has an error on "Set Target = ThisWorkbook.Sheets("PLUG, HEX HEAD").Columns(55)", I guess the function ThisWorkbook.Sheets is not applicable in Personal.xlsb

    What I want to achieve:
    1. Copy all imperial size in column B (starts from B3 to last value)
    2. Paste copied imperial size to row 3 of column with name "mmSize". Column "mmSize" is not fix position.
    If possible add a condition: do not paste if row 3 of column "mmSize" is not blank/empty
    3. Replace imperial size value in column "mmSize" to metric size from lookup table NomDiaMap.xlsx
    4. Column "mmSize" shall be number stored as text only
    5. repeat steps 1-4, on all worksheets except "Catalog Data"

    Thank you in advance.

    regards,
    rxk



    Sub Multi_FindReplace()
        Dim fndList As Variant
        Dim x As Long
        Dim Source As Workbook
        Dim Target As Range
        Dim MyPath As String
        
        MyPath = "G:\88 - Plant 3D stuffs\LookupTable\"   'Change to suit
         
        Set Target = ThisWorkbook.Sheets("PLUG, HEX HEAD").Columns(55)
        On Error Resume Next
        Set Source = Workbooks("NomDiaMap.xlsx")  ' If open
        If Not Source Is Nothing Then
            fndList = Source.Sheets(1).Range("A:B").SpecialCells(2).Value
        Else
            Set Source = Workbooks.Open(MyPath & "Test_Translate.xlsm")   'If closed
            fndList = Source.Sheets(1).Range("A:B").SpecialCells(2).Value
            Source.Close False
        End If
        On Error GoTo 0
         'Loop through each item in Array lists
        For x = LBound(fndList) To UBound(fndList)
                Target.Cells.Replace What:=fndList(x, 1), Replacement:=fndList(x, 2), _
                LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, _
                SearchFormat:=False, ReplaceFormat:=False
        Next x
    End Sub
    NomDiaMap.xlsx
    cs-asmemetric1.xls

  2. #2
    VBAX Newbie
    Joined
    Sep 2020
    Posts
    2
    Location
    I get what i need, but other ideas to make it faster are welcome.

    Sub P3D_Batch_SizeImpToMetric_table()
        Dim fndList As Variant
        Dim x As Long
        Dim Source As Workbook
        Dim Target As Range
        Dim MyPath As String
        Dim SizesRep As Range
        Dim ws As Worksheet
        Dim colNum As Integer
        Dim rng As Range
        Dim rng1 As Range
        
        MyPath = "G:\88 - Plant 3D stuffs\LookupTable\"   'Change to suit
        
        Sheets(1).Activate
        
    '   Start Macro to run for all worksheets "except Catalog Data"
        For Each ws In Worksheets
            Application.ScreenUpdating = False
            If ws.Name <> "Catalog Data" Then
            ws.Activate
         
    '  start copy Imperial Size column
        Range("A2").Select
        Set rng = Cells.Find(What:="Sizes", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False)
        rng.Select
        ActiveCell.Offset(1, 0).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
    '  end copy Imperial Size column
    
    '  start paste Imperial Size to Metric mmSize column
        Range("A2").Select
        Set rng = Cells.Find(What:="mmSize", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False)
        rng.Select
        ActiveCell.Offset(1, 0).Select
        ActiveSheet.Paste
    '  start paste Imperial Size to Metric mmSize column
    
    '   start Replace Imperial to Metric Size from NomDiaMap.xlsx
        Set Target = Selection
        On Error Resume Next
        Set Source = Workbooks("NomDiaMap.xlsx")  ' If open
        If Not Source Is Nothing Then
            fndList = Source.Sheets(1).Range("A:B").SpecialCells(2).Value
        Else
            Set Source = Workbooks.Open(MyPath & "Test_Translate.xlsm")   'If closed
            fndList = Source.Sheets(1).Range("A:B").SpecialCells(2).Value
            Source.Close False
        End If
        On Error GoTo 0
         'Loop through each item in Array lists
        For x = LBound(fndList) To UBound(fndList)
                Target.Cells.Replace What:=fndList(x, 1), Replacement:=fndList(x, 2), _
                LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, _
                SearchFormat:=False, ReplaceFormat:=False
        Next x
    '   end Replace Imperial to Metric Size
    
        End If
    Next ws
    '   Start Macro to run for all worksheets "except Catalog Data"
    
    End Sub

  3. #3
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    1.

    ThisWorkbook.Sheets is not applicable in Personal.xlsb
    ThisWorkbook refers to the WB containing the macro

    ActiveWorkbook refers to the WB that is 'active'

    2. Usually you don't need to .Select an object like a Range in order to act on it

    Worksheets("Sheet1").Range("A1").Copy Worksheets("Sheet2").Range("Z26")
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Posting Permissions

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