SkywardPalm
Board Regular
- Joined
- Oct 23, 2021
- Messages
- 61
- Office Version
- 365
- Platform
- Windows
I'm attempting to pull blank column data from multiple sheets based on the cell value in a column named "NDC." I want the macro to be universal so that if I call it on a sheet that has the "NDC" column, it will pull data into all blank cells based on the NDC column's cell value. It's intended to keep certain libraries filled with relevant data from any referenced source that shares column headers, but could be used in any situation applicable.
I have the VBA code written within a UserForm in which the User selects the sheets to reference...
I have the VBA code written within a UserForm in which the User selects the sheets to reference...
VBA Code:
Option Explicit
Private wbReference As Workbook
Private Sub butCancel_Click()
Unload Me
End Sub
Private Sub butOK_Click()
'Me.Tag = "OK"
Me.Hide
PullData Me.Items
End Sub
Private Sub UserForm_Initialize()
Dim sh As Worksheet
Dim ReferenceFileToOpen As Variant
'Me.ListBox1.Clear
ReferenceFileToOpen = Application.GetOpenFilename(Title:="Browse for Reference Excel File", FileFilter:=" Excel Files(*.xls*),*xls*")
If ReferenceFileToOpen <> False Then
Set wbReference = Application.Workbooks.Open(ReferenceFileToOpen)
Dim n As Long
For n = 1 To wbReference.Sheets.Count
ListBox1.AddItem wbReference.Sheets(n).Name
Next n
End If
End Sub
Public Property Get Items() As String()
Dim i As Long, selected As Long
Dim selectedItems() As String
For i = 0 To ListBox1.ListCount - 1
If ListBox1.selected(i) = True Then
ReDim Preserve selectedItems(selected)
selectedItems(selected) = ListBox1.List(i)
selected = selected + 1
End If
Next i
Items = selectedItems
End Property
Sub PullData(ArrayItems() As String)
Dim x As Integer
Dim rReferenceColHeaders As Range
Dim rActiveColHeaders As Range
Dim rColHead As Range ' Iterates through the Reference column headers
Dim rMatchColHead As Range ' Gets the matching column header
Dim iNumCellsPerColumn As Long ' Defines how many cells per column we're copying
Set rActiveColHeaders = ThisWorkbook.ActiveSheet.Range("A1:AZ1")
'loop from the lower bound of the array to the upper bound of the array - the entire array
For x = LBound(ArrayItems) To UBound(ArrayItems)
Set rReferenceColHeaders = wbReference.Sheets(x).Range("A1:AZ1")
' set number of cells to reference per column/sheet
With wbReference.Sheets(x)
iNumCellsPerColumn = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
' process
'==========================================
' - loop through the Reference column header cells
' -- try to find the matching column
' -- if a match is found, set blank cell values to xlookup from NDC column and highlight found data
For Each rColHead In rReferenceColHeaders
Set rMatchColHead = rActiveColHeaders.Find(rColHead.Text, , xlValues, xlWhole)
If Not (rMatchColHead Is Nothing) Then
'This is the part where I get confused
Else
Debug.Print rColHead & " Header Not Found"
End If
Next rColHead
'create new sheet that displays changed rows with highlighted data
Next x
End Sub