Pleas help merge two small VBA codes together

[Dave01]

Im reaching out to the VBA wizards / masterminds to see if you could help me resolve an issue I have with a section of my code, I have tried merging the two below programs in various ways, but I cant get them to play nice with each other, I would be grateful if someone can help me out.

Objectives

'the Aim is to search Row 1, find header called Purchasing Document, select data to last row, exuding header name
'and name the data range to PurchDoc as in P1 below

'the Two subroutines are from two programs, P1 is mine, P2 is what I sourced from the internet, which I am trying to merge together, but unsuccessful
'It would also be really good if I could clear the name range RNG as if the purchasing document header moves column
'I think it would try to create duplicate name ranges if the original is not cleared. (dont know how to do this) RNG= nothing (maybe??)



P1
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'original code that works and is currently in use
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

Dim RNG As Range
Set RNG = Range("O2:O" & last_row)
ThisWorkbook.Names.Add Name:="PurchDoc", RefersTo:=RNG

P2 - test
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'sourced Code that works Separately in a test module to find and select all the column
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx


Dim Crng As Range
Set Crng = Range("A1:AJ1").Find("Purchasing Document") ' ideally the whole of Row (1:1) Although the data should extend past column AJ anyway
If Crng Is Nothing Then _
MsgBox "Description column was not found." ' dont want this cant remove withought Block if error
Range(Crng, Crng.End(xlDown)).Select
' End If ' if message box enable end if disabled works, other way round, block if error


End Sub

Headers

Company Code

Creation Date

Baseline Payment Dte

Document Date

Net due date

Terms of Payment

Delivery Date

ID

Document number

Vendor

Vendor Name

Reference

Resubmission WI

Actual Agent

Purchasing Document

GR-Based Inv. Verif.

Goods Receipt

GR Done

Workitem Notes

Requisitioner

Created by

Purchasing Group

Business Area

Plant

Workitem Description

Material

Vendor Type

Pending Days

Pending Network Days

Pending Group

Days Overdue

Group Due Next

Queue

Resub Code

Re-Submittion Rasons

GR PO Line Report

Thanks for your help in advance.

Many thanks

Dave.

 

[cmowla]

It's much safer to use Application.Match than Range.Find to search for something. Especially if you're not searching case-sensitive or partial cell contents.

So here is the code for all that you asked for. (BTW, as you assign a named range (refersTo), it actually will override the existing one with the new one.)

Option Explicit

Sub Name_Me_Something_Good()

Dim last_row As Long
last_row = Range("O" & Rows.Count).End(xlUp).Row

Dim columnNumber As Integer
columnNumber = Get_Column_Number("Purchasing Document", ActiveSheet.Name, "1:1")

If columnNumber > 0 Then
    ThisWorkbook.Names.Add Name:="PurchDoc", RefersTo:=Range(Cells(2, columnNumber), Cells(last_row, columnNumber))
Else
    MsgBox "The column " & Chr(34) & "Purchasing Document" & Chr(34) & "was not found.", vbCritical, "Failed"
End If

End Sub


Sub Test__Function_Get_Column_Number()
MsgBox Get_Column_Number("Purchasing Document", ActiveSheet.Name, "1:1")
End Sub
Function Get_Column_Number(search As String, sheetName As String, rangeAddress As String)
On Error GoTo Not_Found:
Get_Column_Number = Application.WorksheetFunction.Match(search, Sheets(sheetName).Range(rangeAddress), 0)
Exit Function
Not_Found:
Get_Column_Number = 0
End Function

 

[GWteB]

My submision would be ...

Public Sub Dave01()
     
    Const SEARCHFOR As String = "purchasing doc"
     
    Dim raHeaders As Range, raResult As Range
    With ThisWorkbook.ActiveSheet
        Set raHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
    End With
    Set raResult = raHeaders.Find(What:=SEARCHFOR, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
                                  SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    With raResult
        Set raResult = .Resize(.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Row - 1).Offset(1)
    End With

    ThisWorkbook.Names.Add Name:="PurchDoc", RefersTo:=raResult
End Sub

 

[Dave01]

Thanks guys

I havnrt had a chance to try them out, Monday morning reporting blues, but I will try them out today, thanks for your help, Im looking for a procedure thats short as the macro I built is very big, so less lines the better. again, high appreciated for your inputs.

 

[GWteB]

You are welcome and thanks for the follow-up.

 

[Dave01]

Perfect thank you, both answers were really good, and worked really well, I went with GWteB, as it was shorter, and would be easier to fault find, upgrade and modify
thanks both for your help.

Dave.

​