VBA change cell values based on the text in one column and a number in another column

Z

zack8576

Active Member
Joined
Dec 27, 2021
Messages
271
Office Version
  1. 365
Platform
  1. Windows
Hi, I am very new to VBA. I need to modify some of the values in column D based on the text in K and the number in L.
We will use column K to determine the type of item, and use the number in L to determine which range this number falls in. It then pulls the correct item# from the master.xlsx and replaces the value in column D.
If the number in L falls in 12"-19", we will assign an item# for 12"; if it falls in 20-32, we will assign it item# for 24"; if it falls in 33"-42, we will assign the item# for 36"...etc
the excel file in the first screenshot is located on a company server, the master.xlsx is on another drive on company server (we can save this file locally if needed)
here is an example: In rows 2, 3, and 7 in screenshot 1, there are:
C BOX (6" WALL) with a height of 14", which is in the range of 12-19, we will need to assign cell D2 the item# F22122J from cell B36 in the master.xlsx file (screenshot 2)
D BOX (6" WALL) with a height of 26", which is in the range of 20-32, we will need to assign cell D3 the item# F22133J from cell B101 in the master.xlsx file (screenshot 3)
C BOX (6" WALL) with a height of 20", which is in the range of 20-32, we will need to assign cell D7 the item# F22123J from cell B37 in the master.xlsx file (screenshot 4)
Any help is greatly appreciated !

1641347396582-png.54437


1641347865090.png

1641348094513.png

1641348214953.png
 
Sort by date Sort by votes
I'd like you to try the following Zack. Locate the code module in the master file (you'll need to save as .xlsm or .xlsb) and save the .csv as a binary excel file called "new.xlsb" in the same folder as the master file. I doubt it will work out perfectly first time, but let's see what it does. Not as sophisticated as Bebo's but may be easier to understand? Let me know how it goes and I'll look at it tomorrow.

VBA Code: 
Option Explicit
Option Compare Text
Sub Zack123()
    Dim wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range, rng As Range
    Dim FileName As String
    Dim x As Long, lr As Long
    
    Application.ScreenUpdating = False
    FileName = ThisWorkbook.Path & "\new.xlsb"
    Set wb2 = Workbooks.Open(FileName)
    Set ws1 = ActiveSheet
    
    Set rng = ws1.Range("K2", Cells(Rows.Count, "K").End(xlUp))
    For Each c In rng
        If c Like "*BOX*" Or _
            c Like "*BASE*" Or _
            c Like "*RISER*" Or _
            c Like "*COLLAR*" Then
                c = c & " " & c.Offset(, 1)
        End If
    Next
    
    wb2.Sheets.Add(after:=wb2.Sheets(Sheets.Count)).Name = "Sheet2"
    Set ws2 = wb2.Sheets("Sheet2")
    
    lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    Sheet1.Range("A1:B" & lr).Copy ws2.Range("C1")
    ws2.Range("C1:D" & lr).Name = "FindItem"
    
    lr = ws1.Cells(Rows.Count, "L").End(xlUp).Row
    ws1.Range("K2:L" & lr).Copy ws2.Range("A2")
    Set rng = ws2.Range("A2:A" & lr)
    
    For Each c In rng
        If c Like "*BOX*" Or _
            c Like "*BASE*" Or _
            c Like "*RISER*" Or _
            c Like "*COLLAR*" Then
                x = Application.WorksheetFunction.Floor(Val(c.Offset(, 1)), 12)
                c = Left(c, Len(c) - 3) & CStr(x) & """"
        End If
    Next
    
    With ws2.Range("B2:B" & lr)
        .Formula = "=IFERROR(Vlookup(A2,FindItem,2,false),"""")"
        .Value = .Value
        .Copy ws1.Range("D2")
    End With
    
    Application.DisplayAlerts = False
    ws2.Delete
    Application.DisplayAlerts = True
End Sub
 
Upvote 0

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
bebo021999 said:
Try below code.
VBA Code: 
Option Explicit
Sub test()
Dim i&
Dim wsM As Worksheet, wsC As Worksheet
Dim cell As Range, cellM As Range
Dim st As String
Set wsM = Workbooks("Master.xlsx").Sheets("Sheet1") ' This is file Master. Adjust to actual Path
Set wsC = Workbooks("CSV.xlsm").Sheets("Sheet1") ' This is Destination file. Adjust to actual Path
With wsC
    For Each cell In .Range("K2:K" & .Cells(Rows.Count, "K").End(xlUp).Row)
        st = ""
        st = UCase(Trim(Left(cell, InStr(cell, "(") - 1))) ' Assum all items in column K contain "("
        For i = wsM.Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1 ' searching from bottom, assums inches# is sorted
            Set cellM = wsM.Cells(i, "A")
            If cellM <> "" Then
                If UCase(cellM) Like st & "*" Then
                    If Val(Mid(cellM, Len(cellM) - 2, 2)) <= Val(Left(cell.Offset(, 1), 2)) Then
                        cell.Offset(, -7).Value = cellM.Offset(, 1).Value
                        Exit For
                    End If
                Else
                    If UCase(cellM) Like "*" & "DIA" & "*" & Right(st, 3) & "*" Then
                        If Val(Mid(cellM, Len(cellM) - 2, 2)) <= Val(Left(cell.Offset(, 1), 2)) Then
                            cell.Offset(, -7).Value = cellM.Offset(, 1).Value
                            Exit For
                        End If
                    End If
                End If
            End If
        Next
    Next
End With
End Sub

View attachment 54549
Click to expand...
Bebo, another concern is that it seems every time we run the macro, this person will need to change the csv file type to xlsm, and change the name of the file. (the original names of these files are a 10 digit number, like 2021120081, 2021120082, 2021120083, there are hundreds or even thousands of these files that will need to be modified).
there will be more than a dozen people using this, and believe it or not, many of these guys barely know how to open an excel file, they will have a hard time go into the VBA editor and change file name...
 
Upvote 0
bebo021999 said:
Try below code.
VBA Code: 
Option Explicit
Sub test()
Dim i&
Dim wsM As Worksheet, wsC As Worksheet
Dim cell As Range, cellM As Range
Dim st As String
Set wsM = Workbooks("Master.xlsx").Sheets("Sheet1") ' This is file Master. Adjust to actual Path
Set wsC = Workbooks("CSV.xlsm").Sheets("Sheet1") ' This is Destination file. Adjust to actual Path
With wsC
    For Each cell In .Range("K2:K" & .Cells(Rows.Count, "K").End(xlUp).Row)
        st = ""
        st = UCase(Trim(Left(cell, InStr(cell, "(") - 1))) ' Assum all items in column K contain "("
        For i = wsM.Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1 ' searching from bottom, assums inches# is sorted
            Set cellM = wsM.Cells(i, "A")
            If cellM <> "" Then
                If UCase(cellM) Like st & "*" Then
                    If Val(Mid(cellM, Len(cellM) - 2, 2)) <= Val(Left(cell.Offset(, 1), 2)) Then
                        cell.Offset(, -7).Value = cellM.Offset(, 1).Value
                        Exit For
                    End If
                Else
                    If UCase(cellM) Like "*" & "DIA" & "*" & Right(st, 3) & "*" Then
                        If Val(Mid(cellM, Len(cellM) - 2, 2)) <= Val(Left(cell.Offset(, 1), 2)) Then
                            cell.Offset(, -7).Value = cellM.Offset(, 1).Value
                            Exit For
                        End If
                    End If
                End If
            End If
        Next
    Next
End With
End Sub

View attachment 54549
Click to expand...
Bebo, I tried this out, there is an error 424 from the highlighted line below:
1641479869132.png


Also, I noticed this code will most likely only work if every cell value in K has brackets, this will cause some other issues.
see below, this is what K typically looks like in these files:

1641479968896.png


and line 1 of K always needs to say description (this file is imported into another program after it gets cleaned up, that program req description to be in K1) :(
 
Upvote 0
kevin9999 said:
I'd like you to try the following Zack. Locate the code module in the master file (you'll need to save as .xlsm or .xlsb) and save the .csv as a binary excel file called "new.xlsb" in the same folder as the master file. I doubt it will work out perfectly first time, but let's see what it does. Not as sophisticated as Bebo's but may be easier to understand? Let me know how it goes and I'll look at it tomorrow.

VBA Code: 
Option Explicit
Option Compare Text
Sub Zack123()
    Dim wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range, rng As Range
    Dim FileName As String
    Dim x As Long, lr As Long
   
    Application.ScreenUpdating = False
    FileName = ThisWorkbook.Path & "\new.xlsb"
    Set wb2 = Workbooks.Open(FileName)
    Set ws1 = ActiveSheet
   
    Set rng = ws1.Range("K2", Cells(Rows.Count, "K").End(xlUp))
    For Each c In rng
        If c Like "*BOX*" Or _
            c Like "*BASE*" Or _
            c Like "*RISER*" Or _
            c Like "*COLLAR*" Then
                c = c & " " & c.Offset(, 1)
        End If
    Next
   
    wb2.Sheets.Add(after:=wb2.Sheets(Sheets.Count)).Name = "Sheet2"
    Set ws2 = wb2.Sheets("Sheet2")
   
    lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    Sheet1.Range("A1:B" & lr).Copy ws2.Range("C1")
    ws2.Range("C1:D" & lr).Name = "FindItem"
   
    lr = ws1.Cells(Rows.Count, "L").End(xlUp).Row
    ws1.Range("K2:L" & lr).Copy ws2.Range("A2")
    Set rng = ws2.Range("A2:A" & lr)
   
    For Each c In rng
        If c Like "*BOX*" Or _
            c Like "*BASE*" Or _
            c Like "*RISER*" Or _
            c Like "*COLLAR*" Then
                x = Application.WorksheetFunction.Floor(Val(c.Offset(, 1)), 12)
                c = Left(c, Len(c) - 3) & CStr(x) & """"
        End If
    Next
   
    With ws2.Range("B2:B" & lr)
        .Formula = "=IFERROR(Vlookup(A2,FindItem,2,false),"""")"
        .Value = .Value
        .Copy ws1.Range("D2")
    End With
   
    Application.DisplayAlerts = False
    ws2.Delete
    Application.DisplayAlerts = True
End Sub
Click to expand...
Kevin, thanks for your response, there is a run time error 1004 from this line: Set wb2 = Workbooks.Open(FileName)

1641480956214.png

I checked the file names, they look correct

1641480924134.png
 
Upvote 0
In response to your feedback, I've ditched the idea of saving the csv with a specific name/format in a specific place, and instead included an Open File dialog box - so the operator can select the actual file they want. Please give this a try:

VBA Code: 
Option Explicit
Option Compare Text
Sub Zack123()
    Dim wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range, rng As Range
    Dim FileName As String
    Dim x As Long, lr As Long
    
    Application.ScreenUpdating = False
    FileName = Application.GetOpenFilename _
    (filefilter:="Excel files (*.csv),*.csv", MultiSelect:=False)
    Set wb2 = Workbooks.Open(FileName)
    Set ws1 = ActiveSheet
    
    Set rng = ws1.Range("K2", Cells(Rows.Count, "K").End(xlUp))
    For Each c In rng
        If c Like "*BOX*" Or _
            c Like "*BASE*" Or _
            c Like "*RISER*" Or _
            c Like "*COLLAR*" Then
                c = c & " " & c.Offset(, 1)
        End If
    Next
    
    wb2.Sheets.Add(after:=wb2.Sheets(Sheets.Count)).Name = "Sheet2"
    Set ws2 = wb2.Sheets("Sheet2")
    
    lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    Sheet1.Range("A1:B" & lr).Copy ws2.Range("C1")
    ws2.Range("C1:D" & lr).Name = "FindItem"
    
    lr = ws1.Cells(Rows.Count, "L").End(xlUp).Row
    ws1.Range("K2:L" & lr).Copy ws2.Range("A2")
    Set rng = ws2.Range("A2:A" & lr)
    
    For Each c In rng
        If c Like "*BOX*" Or _
            c Like "*BASE*" Or _
            c Like "*RISER*" Or _
            c Like "*COLLAR*" Then
                x = Application.WorksheetFunction.Floor(Val(c.Offset(, 1)), 12)
                c = Left(c, Len(c) - 3) & CStr(x) & """"
        End If
    Next
    
    With ws2.Range("B2:B" & lr)
        .Formula = "=IFERROR(Vlookup(A2,FindItem,2,false),"""")"
        .Value = .Value
        .Copy ws1.Range("D2")
    End With
    
    Application.DisplayAlerts = False
    ws2.Delete
    Application.DisplayAlerts = True
End Sub
 
Upvote 0
kevin9999 said:
In response to your feedback, I've ditched the idea of saving the csv with a specific name/format in a specific place, and instead included an Open File dialog box - so the operator can select the actual file they want. Please give this a try:

VBA Code: 
Option Explicit
Option Compare Text
Sub Zack123()
    Dim wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range, rng As Range
    Dim FileName As String
    Dim x As Long, lr As Long
   
    Application.ScreenUpdating = False
    FileName = Application.GetOpenFilename _
    (filefilter:="Excel files (*.csv),*.csv", MultiSelect:=False)
    Set wb2 = Workbooks.Open(FileName)
    Set ws1 = ActiveSheet
   
    Set rng = ws1.Range("K2", Cells(Rows.Count, "K").End(xlUp))
    For Each c In rng
        If c Like "*BOX*" Or _
            c Like "*BASE*" Or _
            c Like "*RISER*" Or _
            c Like "*COLLAR*" Then
                c = c & " " & c.Offset(, 1)
        End If
    Next
   
    wb2.Sheets.Add(after:=wb2.Sheets(Sheets.Count)).Name = "Sheet2"
    Set ws2 = wb2.Sheets("Sheet2")
   
    lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    Sheet1.Range("A1:B" & lr).Copy ws2.Range("C1")
    ws2.Range("C1:D" & lr).Name = "FindItem"
   
    lr = ws1.Cells(Rows.Count, "L").End(xlUp).Row
    ws1.Range("K2:L" & lr).Copy ws2.Range("A2")
    Set rng = ws2.Range("A2:A" & lr)
   
    For Each c In rng
        If c Like "*BOX*" Or _
            c Like "*BASE*" Or _
            c Like "*RISER*" Or _
            c Like "*COLLAR*" Then
                x = Application.WorksheetFunction.Floor(Val(c.Offset(, 1)), 12)
                c = Left(c, Len(c) - 3) & CStr(x) & """"
        End If
    Next
   
    With ws2.Range("B2:B" & lr)
        .Formula = "=IFERROR(Vlookup(A2,FindItem,2,false),"""")"
        .Value = .Value
        .Copy ws1.Range("D2")
    End With
   
    Application.DisplayAlerts = False
    ws2.Delete
    Application.DisplayAlerts = True
End Sub
Click to expand...
I will try this right now, give me a few
 
Upvote 0
kevin9999 said:
In response to your feedback, I've ditched the idea of saving the csv with a specific name/format in a specific place, and instead included an Open File dialog box - so the operator can select the actual file they want. Please give this a try:

VBA Code: 
Option Explicit
Option Compare Text
Sub Zack123()
    Dim wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range, rng As Range
    Dim FileName As String
    Dim x As Long, lr As Long
   
    Application.ScreenUpdating = False
    FileName = Application.GetOpenFilename _
    (filefilter:="Excel files (*.csv),*.csv", MultiSelect:=False)
    Set wb2 = Workbooks.Open(FileName)
    Set ws1 = ActiveSheet
   
    Set rng = ws1.Range("K2", Cells(Rows.Count, "K").End(xlUp))
    For Each c In rng
        If c Like "*BOX*" Or _
            c Like "*BASE*" Or _
            c Like "*RISER*" Or _
            c Like "*COLLAR*" Then
                c = c & " " & c.Offset(, 1)
        End If
    Next
   
    wb2.Sheets.Add(after:=wb2.Sheets(Sheets.Count)).Name = "Sheet2"
    Set ws2 = wb2.Sheets("Sheet2")
   
    lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    Sheet1.Range("A1:B" & lr).Copy ws2.Range("C1")
    ws2.Range("C1:D" & lr).Name = "FindItem"
   
    lr = ws1.Cells(Rows.Count, "L").End(xlUp).Row
    ws1.Range("K2:L" & lr).Copy ws2.Range("A2")
    Set rng = ws2.Range("A2:A" & lr)
   
    For Each c In rng
        If c Like "*BOX*" Or _
            c Like "*BASE*" Or _
            c Like "*RISER*" Or _
            c Like "*COLLAR*" Then
                x = Application.WorksheetFunction.Floor(Val(c.Offset(, 1)), 12)
                c = Left(c, Len(c) - 3) & CStr(x) & """"
        End If
    Next
   
    With ws2.Range("B2:B" & lr)
        .Formula = "=IFERROR(Vlookup(A2,FindItem,2,false),"""")"
        .Value = .Value
        .Copy ws1.Range("D2")
    End With
   
    Application.DisplayAlerts = False
    ws2.Delete
    Application.DisplayAlerts = True
End Sub
Click to expand...
Kevin, this is not working so far, but I like this route though, this would be easy for any of our team members to operate..
two issues, 1. the entire column D got cleared. 2. the height value from L is now in K twice, see below
1641521315175.png
 
Upvote 0
I thought you might like this approach, given what you said about your team's level of expertise. The weights showing twice seems to suggest that the code was run twice on the same csv file, because the code doesn't add them twice. That column D is blank is OK at this stage - it suggests that the ISERROR on the VLOOKUP is doing what it's meant to. I need you to either:
a) freeze the code on the line .Value = .Value and tell me what the formula is doing, or
b) upload a data sample using the XL2BB tool as per bebo's advice in post #36
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Sum the values between two specified column headings - number of columns between will change
2
Replies
14
Views
248
Moley84
M
M
  • Question Question
Match cell contents exactly for find and replace based on a table
Replies
3
Views
772
mumps
mumps
J
  • Question Question
Using CountIf to find total number based on 2 different cells?
Replies
1
Views
134
Asbestos_Jen
Asbestos_Jen
D
  • Question Question
VBA Basic Userform - add -update -delete
Replies
3
Views
616
Drexi
D
D
  • Question Question
Error Retrieving data with XLOOKUP after using VBA to copy to source cells.
Replies
6
Views
390
Alex Blakenburg
A

Forum statistics

Threads
1,223,912
Messages
6,175,341
Members
452,638
Latest member
Oluwabukunmi

Share this page

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