All, I have a spreadsheet where I'm exporting a set of numbers. The spreadsheet tracks missing numbers and looks like this:
[NOTE: this spreadsheet can have 'X' number of columns so I never know the A1:XX range -- I may need to do Range.Find?]
A1 |B1 |C1 |D1 |E1 |F1
------------------------------------------------------------
Column 1 |Missing # |Column 2 |Missing # |Column 3 |Missing#
1 |2 |4 |5 |7 |8
2 | |5 |6 |8 |
3 | |6 | |9 |
The VBA macro in the spreadsheet exports the numbers in the "Missing #" columns. Currently, the macro successfully exports just the numbers from the "Missing #" columns.
BUT --
What I would like to do is export the data so the missing number is prepended/concatenated with the previous (associated) column name. Like this:
Column 1 - 2
Column 2 - 5
Column 2 - 6
Column 3 - 8
Currently, it simply exports like this:
Missing # Missing # Missing#
2 5 8
6
Some of the background logic: The column range is never fixed so it is always A1:??. Also, if a number from a batch is missing, it is always placed in the next column, ie, if a number in the E column is missing, it will be noted as missing in the F column, etc.
And here's what I have so far:
Sub FindMissing()
Application.ScreenUpdating = False
Dim xRg As Range, xRgUni As Range, xFirstAddress As String, xStr As String, srcWB As Workbook
Set srcWB = ThisWorkbook
xStr = "Missing #"
Set xRg = Rows(1).Find(xStr, , xlValues, xlWhole, , , True)
If Not xRg Is Nothing Then
xFirstAddress = xRg.Address
Do
Set xRg = Range("A1:Z1").FindNext(xRg)
If xRgUni Is Nothing Then
Set xRgUni = xRg
Else
Set xRgUni = Application.Union(xRgUni, xRg)
End If
Loop While (Not xRg Is Nothing) And (xRg.Address <> xFirstAddress)
End If
xRgUni.EntireColumn.Copy
Workbooks.Add
ActiveSheet.Paste
fName = srcWB.Path & "\Missing UPCs" & ".csv"
With ActiveWorkbook
.SaveAs Filename:=fName, FileFormat:=xlCSV, CreateBackup:=False
MsgBox "your missing numbers file " & vbNewLine & "has been saved!"
.Close False
End With
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
Thanks for any help, not sure how I go about concatenating the previous column name or taking into account the unknown column range... thanks!
CodePudding user response：
You can use this code - findMissing is doing the job to collect the relevant data in an array.
Public Function findMissing(rgToCheck) As Variant
Dim arrSource As Variant
arrSource = rgToCheck.Value
Dim arrResult As Variant
ReDim arrResult(1 To (UBound(arrSource, 2) / 2) * UBound(arrSource, 1))
Dim r As Long, c As Long, i As Long
For c = 2 To UBound(arrSource, 2) Step 2 'look into every second column
For r = 2 To UBound(arrSource, 1) ' look into each row
If Trim(arrSource(r, c)) <> "" Then
i = i 1
arrResult(i) = arrSource(1, c - 1) & " - " & arrSource(r, c)
End If
Next
Next
If i > 0 Then
ReDim Preserve arrResult(1 To i)
findMissing = arrResult
End If
End Function
You use the result of this function like this
Public Sub saveMissing()
Dim rgToCheck As Range
Set rgToCheck = ActiveSheet.Range("A1").CurrentRegion 'adjust ActiveSheet to your needs
Dim arrMissingValues As Variant
arrMissingValues = findMissing(rgToCheck)
If IsArray(arrMissingValues) Then
Dim wb As Workbook
Set wb = Workbooks.Add
'write array to first sheet
wb.Worksheets(1).Range("A1").Resize(UBound(arrMissingValues)).Value = arrMissingValues
Dim fName As String
fName = srcWB.Path & "\Missing UPCs" & ".csv"
With wb
.SaveAs Filename:=fName, FileFormat:=xlCSV, CreateBackup:=False
MsgBox "your missing numbers file " & vbNewLine & "has been saved!"
.Close False
End With
Else
MsgBox "No missing values"
End If
End Sub
CodePudding user response：
Please, try using the next adapted code. Since yours used to deal with ranges (in a Union range), that way could not be followed. It places the necessary strings in an array and drops its content at the end. No need of optimization...
Sub FindMissing()
Dim xRg As Range, xRgUni As Range, xFirstAddress As String, xStr As String, srcWB As Workbook
Dim fName As String, countMiss As Long
Set srcWB = ThisWorkbook
xStr = "Missing #"
Set xRg = rows(1).Find(xStr, , xlValues, xlWhole, , , True)
countMiss = WorksheetFunction.CountIf(rows(1), xStr) 'number of "Missing #" columns
Dim strPref As String, arrFin, i As Long, j As Long, k As Long, lastR As Long
If Not xRg Is Nothing Then
strPref = xRg.Offset(, -1).Value
lastR = Range("A" & rows.count).End(xlUp).row
ReDim arrFin(1 To lastR, 1 To countMiss): i = 1: k = 1
For i = 1 To countMiss: arrFin(1, i) = xStr: Next: i = 2 'fill the array header
lastR = cells(rows.count, xRg.Column).End(xlUp).row
For j = 1 To lastR
If xRg.Offset(j).Value = "" Then k = k 1: Exit For
arrFin(i j - 1, k) = strPref & " - " & xRg.Offset(j).Value
Next j
xFirstAddress = xRg.address
Do
Set xRg = rows(1).FindNext(xRg)
If xRg.address = xFirstAddress Then Exit Do
If Not xRg Is Nothing Then
strPref = xRg.Offset(, -1).Value
lastR = Range("A" & rows.count).End(xlUp).row
For j = 1 To lastR
If xRg.Offset(j).Value = "" Then k = k 1: Exit For
arrFin(i j - 1, k) = strPref & " - " & xRg.Offset(j).Value
Next j
End If
Loop While (xRg.address <> xFirstAddress)
End If
Workbooks.Add
ActiveSheet.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin
fName = srcWB.Path & "\Missing UPCs" & ".csv"
With ActiveWorkbook
.saveas fileName:=fName, FileFormat:=xlCSV, CreateBackup:=False
MsgBox "Your missing numbers file " & vbNewLine & "has been saved!", vbInformation, _
"Saving confirmation"
.Close False
End With
End Sub
Please, send some feedback after testing it.