VBA Offset maintenance issue

[Baziwan]

I have a database & all information is added to the database via forms. The code uses offset to transfer entered information from textboxes into the relevent columns on the database.
My code works fine. However, several times a year the structure of the database alters (columns are added or removed). When alterations occur I have to go into vba and alter all the offsets.
This can be very time consuming. I've tried to look at ways to adjust the code so that it offsets to a named range by defining a column (eg. Column A defined as DBProductName) but I can't seem to get my head around how to correctly code it.
Below is a sample of the code I'm using that works if the columns are static. What I need is to adjust it to work with a more dynamic database. Any help would be fantastic.

Private Sub cmdAdd_Click()

Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = Worksheets("Database")

With Me.txtProductName
        With ws.Range(Me.cbxVineyard & (Me.cbxCategory) & ("Sort")).Rows(1)
        On Error Resume Next
        .Offset(1, 0).EntireRow.Insert shift:=xlUp
        .Columns(1).Offset(1, 0).Value = Me.txtProductName.Value 'column A
        .Columns(1).Offset(1, 1).Value = Me.txtProductCode.Value 'column B
        .Columns(1).Offset(1, 4).Value = Me.cbxCountry.Value 'column E
        .Columns(1).Offset(1, 5).Value = Me.cbxVineyard.Value 'column F
        .Columns(1).Offset(1, 6).Value = Me.cbxVariety.Value 'column G
 End With
        ws.Range(Me.cbxVineyard & (Me.cbxCategory) & ("Sort")).Select
        Selection.Sort Key1:=Range(Me.cbxVineyard & (Me.cbxCategory) & ("Sort")), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End With
Application.ScreenUpdating = True
Unload Me
End Sub

Thanks in advance

Baziwan

 

[Yongle]

On way
Use MATCH to find the header text column and use that to determine the correct offset
- below assumes headers are in Row 1
- error handling is required to prevent code failing if the header text is not found

Dim c As Long
On Error Resume Next
 c = WorksheetFunction.Match([COLOR=#ff0000]"[I]Product Name[/I][/COLOR]", Sheets("[I]SheetName[/I]").Range("1:1"), 0)
    IF Err.Number > 0 Then
      ???? what happens if the header text is not found
    Else
      carry on
    End If
On Error GoTo 0

Assuming that the offset is from column A, then the offset is c - 1
If "Product Name" is in A1 then c =1 and the offset = 0 (ie c - 1 = 0 )

 

[Baziwan]

Hi,

Thanks for the reply.

I'm kind of new to using the match function & generally at a novice level with VBA

c = WorksheetFunction.Match([COLOR=#ff0000]"[I]Product Name[/I][/COLOR]", Sheets("[I]SheetName[/I]").Range("1:1"), 0)

I understand that this will find the column that has "Product Name" in row 1

Assuming that the offset is from column A, then the offset is c - 1
If "Product Name" is in A1 then c =1 and the offset = 0 (ie c - 1 = 0 )

This I don't understand.

How do I apply this to my code. so that when the form is completed and confirmed, the information goes to the correct column, whether that column "Product Name" is in column A one week or Column Z the next.
I can't seem to apply it correctly.

 

[Yongle]

Something like this - value c needs to be determined for each header "dynamically" and the offset formula is identical for every column

    c = WorksheetFunction.Match("Product Name", Sheets("SheetName").Range("1:1"), 0)
    .Columns(1).Offset(1, c-1).Value = Me.txtProductName.Value 'column A

    c = WorksheetFunction.Match("Product Code", Sheets("SheetName").Range("1:1"), 0)
    .Columns(1).Offset(1, c-1).Value = Me.txtProductCode.Value 'column B

or you could do this

    c = WorksheetFunction.Match("Product Name", Sheets("SheetName").Range("1:1"), 0) [COLOR=#ff0000]-1[/COLOR]
    .Columns(1).Offset(1, [COLOR=#ff0000]c[/COLOR]).Value = Me.txtProductName.Value 'column A

    c = WorksheetFunction.Match("Product Code", Sheets("SheetName").Range("1:1"), 0) [COLOR=#ff0000]-1[/COLOR]
    .Columns(1).Offset(1, [COLOR=#ff0000]c[/COLOR]).Value = Me.txtProductCode.Value 'column B

As you can see the code is very repetitive and the repitition could easily be avoided
- if you post a list of the headers that require matching then I will update the thread tomorrow with the repetitions removed

 

[Baziwan]

Thanks very much Yongle. I'll try this out & I'll also add a list of headers.
Thanks for your help

 

[Baziwan]

[TABLE="class: grid, width: 150, align: left"]
<tbody>[TR]
[TD]Product

[/TD]
[/TR]
[TR]
[TD]Product Code

[/TD]
[/TR]
[TR]
[TD]Quantity
[/TD]
[/TR]
[TR]
[TD]Location
[/TD]
[/TR]
[TR]
[TD]LCB 1 Qty
[/TD]
[/TR]
[TR]
[TD]LCB 1 Rotation
[/TD]
[/TR]
[TR]
[TD]LCB 1 Received
[/TD]
[/TR]
[TR]
[TD]LCB 2 Qty
[/TD]
[/TR]
[TR]
[TD]LCB 2 Rotation
[/TD]
[/TR]
[TR]
[TD]LCB 2 Received
[/TD]
[/TR]
[TR]
[TD]LCB 3 Qty

[/TD]
[/TR]
[TR]
[TD]LCB 3 Rotation
[/TD]
[/TR]
[TR]
[TD]LCB 3 Received
[/TD]
[/TR]
[TR]
[TD]Country
[/TD]
[/TR]
[TR]
[TD]Vineyard
[/TD]
[/TR]
[TR]
[TD]Grape Variety
[/TD]
[/TR]
[TR]
[TD]Cost
[/TD]
[/TR]
[TR]
[TD]Duty
[/TD]
[/TR]
[TR]
[TD]Cost + Duty
[/TD]
[/TR]
[TR]
[TD]Total Cost
[/TD]
[/TR]
</tbody>[/TABLE]
I tested it & it worked like a charm thanks Here is a list of column headers. My problem was that LCB columns get added & removed.

 

[Yongle]

Thanks - will look at this tomorrow

Just a thought - VBA needs to know which userform box belongs to each header

You could add a (hidden?) sheet to your workbook where
- column A = header
- column B = userform box name
- probably easier to maintain
- and VBA uses VBA to find the correct box name

OR

- could do it entirely in VBA

Which do you prefer?

thanks

 

[Yongle]

Above should read...

- and VBA uses VLOOKUP to find the correct box name

 

[Yongle]

Field lookup
- create a new sheet and with your headers (per post#6) in column A and the UserForm box name in column B
- select columns A & B and type Fields in the name box (creates named range Fields with RefersTo A:B )

To avoid the code crashing
The loop is run twice
- the first time simply to prove that all headers exist - causing the sub to exit if they do not - with a message box telling you which headers are missing
- the second loop requires no error checking

Private Sub cmdAdd_Click()
Application.ScreenUpdating = False
    Dim oSet As Long, hdr As Variant, ctrl As String, msg As String, arr As Variant
    Dim ws As Worksheet
    
    Set ws = Worksheets("Database")
    arr = Array("Product", "Product Code", "Country", "Vineyard", "Grape Variety")
With Me.txtProductName
    With ws.Range(Me.cbxVineyard & (Me.cbxCategory) & ("Sort")).Rows(1)
   
[I][COLOR=#000080]'test headers exist[/COLOR][/I]
        For Each hdr In arr
            On Error GoTo 0
            On Error Resume Next
            oSet = WorksheetFunction.Match(hdr, Sheets("Sheet1").Rows(1), 0) - 1
                If Err.Number > 0 Then msg = msg & vbCr & hdr
            Next hdr
                If Len(msg) > 0 Then
                    MsgBox msg, vbExclamation, "MISSING FIELDS": GoTo TheEnd
                End If
[I][COLOR=#000080]'update cells[/COLOR][/I]
            .Offset(1, 0).EntireRow.Insert shift:=xlUp
            For Each hdr In arr
                oSet = WorksheetFunction.Match(hdr, Sheets("Sheet1").Rows(1), 0) - 1
                ctrl = WorksheetFunction.VLookup(hdr, Range("Fields"), 2, 0)
                .Columns(1).Offset(1, oSet).Value = Me.Controls(ctrl).Value
            Next hdr
        End With
End With
        ws.Range(Me.cbxVineyard & (Me.cbxCategory) & ("Sort")).Select
        Selection.Sort Key1:=Range(Me.cbxVineyard & (Me.cbxCategory) & ("Sort")), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With

TheEnd:
Unload Me
Application.ScreenUpdating = True

End Sub

 

[Norie]

If you know the column number of a heading, e.g Product Number, then you don't need to use Offset.