Using Excel VBA I am trying to create a joint string in another workbook from my current

user_15898400 0
Viewed 59

what im trying to do is this:

One work book has 3 columns where numbers go, and each column has the words "critical, consumable and Maintenance". Whenever there is a value in these columns (even if 2 of them have it), on another excel workbook I need to type the column names together like "Critical & Consumable"

Current Code:

Sub Sampleif()

Dim c As String
c = "Critical"

Dim d As String
d = "Consumables"

Dim e As String
e = "Routine Maintenance"

Dim x1 As ThisWorkbook
Set x1 = Workbooks("Data Collection with Macro.xlsm")


Dim y1 As Workbook
Set y1 = Workbooks("Facilitation.xlsx")

Dim r As Integer
Dim lastRow As Integer

lastRow = x1.Sheets("data").Cells(Rows.Count, 1).End(xlUp).Row
' Debug.Print (lastRow)

Dim q As String
q = 7



For r = 9 To lastRow
    If CInt(x1.Sheets("data").Cells(r, 13).Value) Or CInt(x1.Sheets("data").Cells(r, 14).Value) Or CInt(x1.Sheets("data").Cells(r, 15).Value) > 0 Then
        Debug.Print (x1.Sheets("data").Cells(r, 13).Value)
        y1.Sheets("SOS Q&A - VENDORS").Cells(q, 31).Value = c
        
        
        ElseIf CInt(x1.Sheets("data").Cells(r, 13).Value) Or CInt(x1.Sheets("data").Cells(r, 14).Value) Or CInt(x1.Sheets("data").Cells(r, 15).Value) > 0 Then
        y1.Sheets("SOS Q&A - VENDORS").Cells(q, 31).Value = d
        
        ElseIf CInt(x1.Sheets("data").Cells(r, 13).Value) Or CInt(x1.Sheets("data").Cells(r, 14).Value) Or CInt(x1.Sheets("data").Cells(r, 15).Value) > 0 Then
        y1.Sheets("SOS Q&A - VENDORS").Cells(q, 31).Value = e
        
        
        
    End If
    q = q + 3
    
Next r

End Sub
if-statement for-loop vba excel
1 Answers

Join Strings in Another Workbook

enter image description here

  • This code could be written to be more efficient in many ways, but I opted to stay as true as possible to your idea hoping it would be more readable (understandable) and teach you much more.
  • Adjust the values in the constants section, the workbooks and the worksheets (play with them).
Option Explicit

Sub Sampleif()
    
    ' Source
    Const sFirst As Long = 9 ' Source First Row
    Const slrCol As Long = 1 ' Source Last Row Column
    ' The following two arrays have to have the same number of elements.
    Dim sCols As Variant: sCols = Array(13, 14, 15) ' Source Columns Array
    Dim sStrings As Variant ' Source Strings Array
    sStrings = Array("Critical", "Consumables", "Routine Maintenance")
    ' Destination
    Const dFirst As Long = 7 ' Destination First Row
    Const dCol As Long = 31 ' Destination Column Number
    Const drOffset As Long = 3 ' Destination Row Offset
    Const dDelim As String = " & " ' Destination Delimiter
    
    ' Source
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    ' If it's not the workbook containing this code then do:
    'Set swb = Workbooks("Data Collection with Macro.xlsm")
    Dim sws As Worksheet: Set sws = swb.Worksheets("data")
    Dim sLast As Long: sLast = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
    
    ' Destination
    Dim dwb As Workbook: Set dwb = Workbooks("Facilitation.xlsx")
    Dim dws As Worksheet: Set dws = dwb.Worksheets("SOS Q&A - VENDORS")
    Dim dRow As Long: dRow = dFirst ' Destination Row
    Dim dLen As Long: dLen = Len(dDelim) ' Destination Delimiter Length
    
    ' Arrays' Limits
    Dim cLower As Long: cLower = LBound(sCols) ' Arrays' Lower Index
    Dim cUpper As Long: cUpper = UBound(sCols) ' Arrays' Upper Index
    
    ' Declare additional variables.
    Dim cdString As String ' Current Destination String
    Dim r As Long ' Source Rows Counter
    Dim c As Long ' Arrays' Elements Counter
    
    ' Loop through rows of Source Worksheet.
    For r = sFirst To sLast
        ' Reset Current Destination String (there may be one for each row).
        cdString = ""
        ' Loop through the elements of the Arrays.
        For c = cLower To cUpper
            ' Check if current value in the cell at the intersection
            ' of the Current Source Row and the Current Source Column
            ' is equal to the Current Source String.
            If sws.Cells(r, sCols(c)).Value = sStrings(c) Then
                ' Append Current Source String and the Destination Delimiter
                ' to Current Destination String
                cdString = cdString & sStrings(c) & dDelim
            'Else
                ' Values are not equal. Do nothing.
            End If
        Next c
        ' Test if any Source String has been appended
        ' to the Current Destination String.
        If Len(cdString) > 0 Then
            ' Remove trailing dDelim from Current String.
            cdString = Left(cdString, Len(cdString) - dLen)
            ' Write Current String to Current Destination Cell.
            dws.Cells(dRow, dCol).Value = cdString
            ' Determine next Destination Row.
            dRow = dRow + drOffset
        'Else
            ' No string found. Do nothing.
        End If
    Next r

End Sub
user_98140690
Related