VBA Offset maintenance issue

Baziwan

New Member
Joined
Sep 4, 2018
Messages
32
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.

Code:
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
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
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

Code:
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 )
 
Upvote 0
Hi,

Thanks for the reply.

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

Code:
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.
 
Upvote 0
Something like this - value c needs to be determined for each header "dynamically" and the offset formula is identical for every column
Code:
    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
Code:
    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
 
Last edited:
Upvote 0
Thanks very much Yongle. I'll try this out & I'll also add a list of headers.
Thanks for your help
 
Upvote 0
Product

Product Code

Quantity
Location
LCB 1 Qty
LCB 1 Rotation
LCB 1 Received
LCB 2 Qty
LCB 2 Rotation
LCB 2 Received
LCB 3 Qty

LCB 3 Rotation
LCB 3 Received
Country
Vineyard
Grape Variety
Cost
Duty
Cost + Duty
Total Cost

<tbody>
</tbody>
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.
 
Upvote 0
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
 
Upvote 0
Above should read...

- and VBA uses VLOOKUP to find the correct box name :eek:
 
Upvote 0
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

Code:
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
 
Upvote 0
If you know the column number of a heading, e.g Product Number, then you don't need to use Offset.
 
Upvote 0

Forum statistics

Threads
1,213,491
Messages
6,113,963
Members
448,536
Latest member
CantExcel123

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top