The script fills an array from a sheet called "Tigers" with 6 strings. Then it is supposed to compare that array to a differnt sheet titled "Elephants" and tell me if it finds an exact match. The troublesome code is found at the Application.Match method
Any help understanding how to correctly script a match with multiple values would be appreciated.
Sub matchData()
Dim arrCompare(5) As Variant
Dim intRow As Integer
Dim varRes As Variant
Set sht = ActiveSheet
Set shtTigers = Worksheets("Tigers").Range("A2:A100")
Set shtElephants = Worksheets("Elephants").Range("A2:A100")
Sheets("Elephants").Activate
For intRow = 2 To 100
arrCompare(0) = Worksheets("Elephants").Cells(intRow, 1).Value
arrCompare(1) = Worksheets("Elephants").Cells(intRow, 2).Value
arrCompare(2) = Worksheets("Elephants").Cells(intRow, 4).Value
arrCompare(3) = Worksheets("Elephants").Cells(intRow, 5).Value
arrCompare(4) = Worksheets("Elephants").Cells(intRow, 7).Value
arrCompare(5) = Worksheets("Elephants").Cells(intRow, 9).Value
'compare all 6 strings in array against Elephant sheet rows for a match
varRes = Application.Match(arrCompare(), shtTigers, 0)
'also tried
'varRes = Application.Match(((arrCompare(0))*((arrCompare(1))*((arrCompare(2)) * ((arrCompare(3)) * ((arrCompare(4)) * ((arrCompare(5))*((arrCompare(6)),shtTigers, 0)
'messagebox just gives a Error 13 or 2042 for varRes
MsgBox ("varRes = " & varRes)
Next
End Sub
Match requires a single lookup value but you're trying to pass the whole array. Iterate one element at at time instead:
Dim counter as Integer
For x = 0 to 5
If Not IsError(Application.Match(arrCompare(x), shtTigers, 0)) Then
counter = counter + 1
End If
Next x
If counter = 6 Then Debug.Print "Matches found"
Related
I am trying to make an auto scheduling program with an excel.
For example, each number is certain job assigned to the person given day.
1/2 1/3 1/4 1/5
Tom 1 2 2 ?
Justin 2 3 1 ?
Mary 3 3 ?
Sam 1 ?
Check O O X ? ## check is like =if(b2=c2,"O","X")
The things I want to make sure is every person is given a different job from yesterday.
My idea
while
randomly distribute jobs for 1/5
wend CheckCell = "O"
But I found that checking cell in the vba script doesn't work - the cell is not updated in each while loop.
Could you give me a little pointer for these kinds of program? Because I am new to vbaScript, any kinds of help would be appreciated.
Using VBA, I'm sure there are better ways to do this, but this will check the values from the penultimate column against values from last column and if they match it will write "O" to under the last column, else it will write "X":
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
counter = 0 'set counter
For i = 2 To LastRow 'loop through penultimate column and add values to array
If ws.Cells(i, LastCol - 1).Value <> "" Then
Values = Values & ws.Cells(i, LastCol - 1) & ","
End If
Next i
Values = Left(Values, Len(Values) - 1)
Values = Split(Values, ",") 'split values into array
For i = 2 To LastRow 'loop through last column and add values to array
If ws.Cells(i, LastCol).Value <> "" Then
ValuesCheck = ValuesCheck & ws.Cells(i, LastCol) & ","
End If
Next i
ValuesCheck = Left(ValuesCheck, Len(ValuesCheck) - 1)
ValuesCheck = Split(ValuesCheck, ",")
For y = LBound(Values) To UBound(Values) 'loop through both arrays to find all values match
For x = LBound(ValuesCheck) To UBound(ValuesCheck)
If Values(y) = ValuesCheck(x) Then counter = counter + 1
Next x
Next y
If counter = UBound(Values) + 1 Then 'if values match
ws.Cells(LastRow + 1, LastCol).Value = "O"
Else 'else write X
ws.Cells(LastRow + 1, LastCol).Value = "X"
End If
End Sub
just to clarify are you looking to implement the random number in the vba or the check.
To do the check the best way would be to set the area as a range and then check each using the cells(r,c) code, like below
Sub checker()
Dim rng As Range
Dim r As Integer, c As Integer
Set rng = Selection
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If rng.Cells(r, c) = rng.Cells(r, c + 1) Then
rng.Cells(r, c).Interior.Color = RGB(255, 0, 0)
End If
Next c
Next r
End Sub
this macro with check the text you have selected for the issue and change the cell red if it matches the value to the right.
To make it work for you change set rng = selection to your range and change the rng.Cells(r, c).Interior.Color = RGB(255, 0, 0) to the action you want
A sligthly different approach than the other answers.
Add this function:
Function PickJob(AvailableJobs As String, AvoidJob As String)
Dim MaxTries As Integer
Dim RandomJob As String
Dim Jobs() As String
Jobs = Split(AvailableJobs, ",")
MaxTries = 100
Do
MaxTries = MaxTries - 1
If MaxTries = 0 Then
MsgBox "Could find fitting job"
End
End If
RandomJob = Jobs(Int((1 + UBound(Jobs)) * Rnd()))
Loop Until RandomJob <> AvoidJob
PickJob = RandomJob
End Function
And put this formula in your sheet
=PickJob("1,2,3",D2)
where D2 points to is the previous job
I'm having trouble with my loop not running throughout my entire sheet 1. If the value in Sheet 1 "tests" exist in sheet 2 "cancer". Then i want the value in sheet 2 "cancer" to be placed into sheet 1 "Tests". The code works except for the loop. Currently it only applies to the first record in my first sheet then stops.
Sub Testing()
Dim x As Long
Dim y As Long
x = 2
y = 2
Do While Sheets("Cancer").Cells(y, 1).Value <> ""
If LCase(Trim(Sheets("Cancer").Cells(y, 1).Text)) = LCase(Trim(Sheets("Tests").Cells(x, 3).Text)) Then
If Sheets("Tests").Cells(x, 4).Value = "" Then
Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
x = x + 1
End If
End If
y = y + 1
Loop
End Sub
I would use two for loops
for y = 2 to 10000 'the range your values are found
if Sheets("Cancer").Cells(y, 1).Value <> "" then
for x = 2 to 10000 'the range your values are in
If LCase(Trim(Sheets("Cancer").Cells(y, 1).Text)) = LCase(Trim(Sheets("Tests").Cells(x, 3).Text)) and Sheets("Tests").Cells(x, 4).Value = "" Then
Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
End If
next
end if
next
The reason for the loop not running throughout the entire sheet 1 is because of these two lines:
If LCase(Trim(Sheets("Cancer").Cells(y, 1).Text)) = LCase(Trim(Sheets("Tests").Cells(x, 3).Text)) and Sheets("Tests").Cells(x, 4).Value = ""
If these conditionals aren't both true, then x will never loop to its next iteration, and you'll have gone through looping through each value of Sheet2 "Cancer" while checking only the same record of Sheet1 "Tests".
You've almost qualified all of your ranges. You missed one. Try changing the line:
Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
to
Sheets("Tests").Cells(x, 4) = (Trim(Sheets("Cancer").Cells(y, 3).Text))
I have a excel sheet looks like this: "Sheet1" & "Sheet2" and I wanted the result as shown in "Sheet3".
Sample Data
Eventually I would like to put a "Button" in a separate sheet (Control Panel) and when clicking on it I need to combine the data from "Sheet1" and "Sheet2" with the transpose effect as shown in "Sheet3".
How can I automate this using macro since there are ~2000 "rows" in Sheet 1 and ~1000 in Sheet 2. I'm new to macro so hopefully I can make this automated otherwise I'm copying and pasting all of them manually.
Thanks!
It might be helpful to use a function that returns the last row of a worksheet:
Public Function funcLastRow(shtTarget As Worksheet, Optional iColLimit As Integer = -1) As Long
If iColLimit = -1 Then
iColLimit = 256
End If
Dim rowMaxIndex As Long
rowMaxIndex = 0
Dim ctrCols As Integer
For ctrCols = 1 To iColLimit
If shtTarget.Cells(1048576, ctrCols).End(xlUp).Row > rowMaxIndex Then
rowMaxIndex = shtTarget.Cells(1048576, ctrCols).End(xlUp).Row
End If
Next ctrCols
funcLastRow = rowMaxIndex
End Function
You could use it simply like so:
Dim lLastRow As Long
lLastRow = funcLastRow(Sheets(1))
Please let us know if that worked for you thanks
Here is an all formula solution (No Macro)
Data is in Sheet1 A to I and Sheet2 A to G
I am assuming you have only 6 departments. although if you have additional, the formulas need very little or may be no modification.
In Sheet 3
Get the userID repeated six times
A2 = INDEX(Sheet1!A:A,1+QUOTIENT(ROW()-ROW($A$2)+6,6))
Get Name, Gender & Country
B2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:B$1),FALSE)
C2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:C$1),FALSE)
D2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:D$1),FALSE)
Get Access to department. The "" & ... is to avoid 0 in case the resulting cell was blank.
E2 = "" & IF(SUMPRODUCT(--(Sheet1!$A$1:$I$1=F2))>0,HLOOKUP(F2,Sheet1!$A$1:$I$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0),FALSE),HLOOKUP(F2,Sheet2!$A$1:$G$3000,MATCH(A2,Sheet2!$A$1:$A$3000,0),FALSE))
F2:F7 the departments are Input manually (no formula). F8 is linked to F2 so that the depts repeat when dragged down
G2 = "" & IF(SUMPRODUCT(--(Sheet1!$A$1:$I$1=F2))>0,INDEX(Sheet1!$I$1:$I$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0)),INDEX(Sheet2!$G$1:$G$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0)))
If you need, I can prepare a google sheet to demo. Cheers.
This code works very well for Transpose and concatenate of big data.
Sub ConcatData()
Dim X As Double
Dim DataArray(5000, 2) As Variant
Dim NbrFound As Double
Dim Y As Double
Dim Found As Integer
Dim NewWks As Worksheet
Cells(1, 1).Select
Let X = ActiveCell.Row
Do While True
If Len(Cells(X, 1).Value) = Empty Then
Exit Do
End If
If NbrFound = 0 Then
NbrFound = 1
DataArray(1, 1) = Cells(X, 1)
DataArray(1, 2) = Cells(X, 2)
Else
For Y = 1 To NbrFound
Found = 0
If DataArray(Y, 1) = Cells(X, 1).Value Then
DataArray(Y, 2) = DataArray(Y, 2) & ", " & Cells(X, 2)
Found = 1
Exit For
End If
Next
If Found = 0 Then
NbrFound = NbrFound + 1
DataArray(NbrFound, 1) = Cells(X, 1).Value
DataArray(NbrFound, 2) = Cells(X, 2).Value
End If
End If
X = X + 1
Loop
Set NewWks = Worksheets.Add
NewWks.Name = "SummarizedData"
Cells(1, 1).Value = "Names"
Cells(1, 2).Value = "Results"
X = 2
For Y = 1 To NbrFound
Cells(X, 1).Value = DataArray(Y, 1)
Cells(X, 2).Value = DataArray(Y, 2)
X = X + 1
Next
Beep
MsgBox ("Summary is done!")
End Sub
I wanted excel to go through every single cell of a column, perform an operation on it and then copy the results on another column.
This was my initial code:
For i = 2 To dataRows
' Cells(i, aStampCol) = Cells(i, stampCol) - stim1TimeStamp
'Next i
This code actually worked, but ran extremely slowly, I looked at another post and they were saying it was better to just copy the column into an array, manipulate it and then copy it back to a column.
So I wrote the following code:
cellsAStamp = Range(Cells(2, stampCol), Cells(datarows, stampCol))
For i = 0 To datarows - 2
cellsAStamp(i) = cellsAStamp(i) - stim1TimeStamp
Next i
Range(Cells(2, aStampCol), Cells(endRow, aStampCol)) = cellsAStamp
The problem is, as soon as the for loop is initiated, I get a "Subscript out of Range" error. I get the impression that the cellsAsStamp is not storing the data properly, but I don't exactly know how to solve this problem, or for that matter, what the problem is!
I've pasted my full code below so you can look at how I initialized the variables:
Sub WM()
Dim col As Integer
Dim spanCol As Integer
Dim msgCol As Integer
Dim stampCol As Integer 'The column containing the timestamp
Dim aStampCol As Integer 'The column containing the adjusted timestamp
Dim row As Long
Dim startRow As Long
Dim stimRow As Long 'the row on the Sample_Message column that says "stim1"
Dim endRow As Long 'the row on the Sample_Message column that says "participant_trial_end"
Dim triNum() As String 'a string array that will hold "Trial: x" after it has been split
Dim stim1TimeStamp As Long
Dim cellsAStamp() As Variant 'will contain the names of all the NoBlink sheets to allow for
'Identifies Timestamp column, adds ADJUSTED_TIMESTAMP column
For stampCol = 1 To 10
If Cells(1, stampCol) = "TIMESTAMP" Then
aStampCol = stampCol
colLetter = ConvertToLetter(stampCol)
Columns(colLetter & ":" & colLetter).Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
stampCol = stampCol + 1
Cells(1, aStampCol) = "ADJUSTED_TIMESTAMP"
GoTo out
End If
Next stampCol
out:
'Identifies Trial Label column
For col = 1 To 10
If Cells(1, col) = "TRIAL_LABEL" Then
GoTo out1
End If
Next col
out1:
'Identifies Span column
For spanCol = 1 To 10
If Cells(1, spanCol) = "span" Then
GoTo out2
End If
Next spanCol
out2:
'Identifies Message column
For msgCol = 1 To 10
If Cells(1, msgCol) = "SAMPLE_MESSAGE" Then
GoTo out3
End If
Next msgCol
out3:
'Goes through Trial_Label column and deletes trials 1 and 2
row = 2
While Cells(row, col) Like "Trial: [12]"
row = row + 1
Wend
row = row - 1
If row = 1 Then 'in case the trials weren't there, it wont start at the header
row = 2
GoTo skipDelete
End If
Rows("2:" & CStr(row)).Delete
skipDelete:
'Goes through Trial_Label column and stops once the trial changes
row = 2
GoTo stillMoreLeft
stillMoreLeft:
startRow = row
currTrial = Cells(row, col) 'did not initialize currSpan and currTrial as strings
currSpan = Cells(row, spanCol)
While currTrial = Cells(row, col)
'highlights any row that has a message
If Cells(row, msgCol) <> "." Then
Rows(CStr(row) & ":" & CStr(row)).Interior.Color = vbYellow
End If
'Identifies the row that contains "stim1" in Sample_Message
If Cells(row, msgCol) = "stim1" Then
stimRow = row
End If
'Identifies the row that contains "participant_trial_end" in Sample_Message
If Cells(row, msgCol) = "participant_trial_end" Then
endRow = row
End If
row = row + 1
Wend
row = row - 1
'Copies all of the rows containted in a trial
Rows(CStr(stimRow) & ":" & CStr(endRow)).Select
Selection.Copy
'Creates new sheet that will be named appropriately
Worksheets.Add
triNum = Split(currTrial)
currSheetName = "Trial" & triNum(1) & "Span" & currSpan
ActiveSheet.Name = currSheetName
'Pastes all the rows contained in at trial
Rows("2:2").Select
ActiveSheet.Paste
'Gets timestamp for stim1
stim1TimeStamp = Cells(2, stampCol)
'Puts the whole timestamp column in an array/ Does the appropriate calculations to each value
datarows = endRow - stimRow + 2
cellsAStamp = Range(Cells(2, stampCol), Cells(datarows, stampCol)) 'looks like a legit way to use range
For i = 0 To datarows - 2
cellsAStamp(i) = cellsAStamp(i) - stim1TimeStamp
Next i
Range(Cells(2, aStampCol), Cells(endRow, aStampCol)) = cellsAStamp
'Fills the Adjusted_TimeStamp column
'dataRows = endRow - stimRow + 2
'For i = 2 To dataRows
' Cells(i, aStampCol) = Cells(i, stampCol) - stim1TimeStamp 'This equation says: the Adjusted_Time_Stamp=TimeStamp-TimeStamp of Stim1
'Next i
'Copies header row and pastes it to first row of most recent trial sheet
Sheets(ActiveWorkbook.Name).Select
Rows("1:1").Select
Selection.Copy
Sheets(currSheetName).Select
Rows("1:1").Select
ActiveSheet.Paste
row = row + 1 'we increment the row so that on the next line, when they check for whether the cell is empty or not, we aren't looking at the last cell of our current trial, but the first cell of our following trial
Sheets(ActiveWorkbook.Name).Select
'Looks to see if there is still a trial left, if so, it goes through all of it
If Cells(row, col) <> "" Then
GoTo stillMoreLeft
Else
bob = 1 + 1
End If
End Sub
Function ConvertToLetter(iCol As Integer) As String
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function
When you read a range into an array, it will be a 2D array (1-based) -- dimension one is the rows, dimension two is the columns -- even if there is just one column. So try:
cellsAStamp(i,1) = cellsAStamp(i,1) - stim1TimeStamp
OK, I have a simple problem that I need help with in a VBA Macro. I have an excel sheet that looks like this...
Product # Count
101 1
102 1
101 2
102 2
107 7
101 4
101 4
189 9
I need a macro that adds up the "count" column based on the Product Number Column. I want it to over all look like this after I am done...
Product # Count
101 7
102 7
107 7
189 9
I am an amiture to VBA so I would love any help I can get.
Assuming the data is in columns A and B, you can do it with a formula:
=SUMIF(A:A,101,B:B)
Or if you put 101 in C1:
=SUMIF(A:A,C1,B:B)
EDIT
However if you still require VBA, here is my (quick and dirty) proposal - I use a dictionary to keep track of the sum for each item.
Sub doIt()
Dim data As Variant
Dim i As Long
Dim countDict As Variant
Dim category As Variant
Dim value As Variant
Set countDict = CreateObject("Scripting.Dictionary")
data = ActiveSheet.UsedRange 'Assumes data is in columns A/B
'Populate the dictionary: key = category / Item = count
For i = LBound(data, 1) To UBound(data, 1)
category = data(i, 1)
value = data(i, 2)
If countDict.exists(category) Then
countDict(category) = countDict(category) + value 'if we have already seen that category, add to the total
Else
countDict(category) = value 'first time we find that category, create it
End If
Next i
'Copy dictionary into an array
ReDim data(1 To countDict.Count, 1 To 2) As Variant
Dim d As Variant
i = 1
For Each d In countDict
data(i, 1) = d
data(i, 2) = countDict(d)
i = i + 1
Next d
'Puts the result back in the sheet in column D/E, including headers
With ActiveSheet
.Range("D1").Resize(UBound(data, 1), UBound(data, 2)) = data
End With
End Sub
The easiest thing is to use a Pivot Table in this case as Tim suggested.
Here is a VBA solution that uses multidimensional arrays. I noticed you said you are a bit new to VBA so I tried to put some meaningful comments in there. One thing that might look strange is when I redimension the arrays. That's because when you have multidimensional arrays you can only ReDim the last dimension in the array when you use the Preserve keyword.
Here is how my data looked:
Product Count
101 1
102 1
101 2
102 2
107 7
101 4
101 4
189 9
And here is the code. It has the same output as my last answer. Test this in a new workbook and put the test data in Sheet1 with headers.
Option Explicit
Sub testFunction()
Dim rng As Excel.Range
Dim arrProducts() As String
Dim i As Long
Set rng = Sheet1.Range("A2:A9")
arrProducts = getSumOfCountArray(rng)
Sheet2.Range("A1:B1").Value = Array("Product", "Sum of Count")
' go through array and output to Sheet2
For i = 0 To UBound(arrProducts, 2)
Sheet2.Cells(i + 2, "A").Value = arrProducts(0, i)
Sheet2.Cells(i + 2, "B").Value = arrProducts(1, i)
Next
End Sub
' Pass in the range of the products
Function getSumOfCountArray(ByRef rngProduct As Excel.Range) As String()
Dim arrProducts() As String
Dim i As Long, j As Long
Dim index As Long
ReDim arrProducts(1, 0)
For j = 1 To rngProduct.Rows.Count
index = getProductIndex(arrProducts, rngProduct.Cells(j, 1).Value)
If (index = -1) Then
' create value in array
ReDim Preserve arrProducts(1, i)
arrProducts(0, i) = rngProduct.Cells(j, 1).Value ' product name
arrProducts(1, i) = rngProduct.Cells(j, 2).Value ' count value
i = i + 1
Else
' value found, add to id
arrProducts(1, index) = arrProducts(1, index) + rngProduct.Cells(j, 2).Value
End If
Next
getSumOfCountArray = arrProducts
End Function
Function getProductIndex(ByRef arrProducts() As String, ByRef strSearch As String) As Long
' returns the index of the array if found
Dim i As Long
For i = 0 To UBound(arrProducts, 2)
If (arrProducts(0, i) = strSearch) Then
getProductIndex = i
Exit Function
End If
Next
' not found
getProductIndex = -1
End Function
Sub BestWaytoDoIt()
Dim i As Long ' Loop Counter
Dim int_DestRwCntr As Integer ' Dest. sheet Counter
Dim dic_UniquePrd As Scripting.Dictionary
Set dic_UniquePrd = New Scripting.Dictionary
For i = 2 To Sheet1.Range("A" & Sheet1.Cells.Rows.Count - 1).End(xlUp).Row
If dic_UniquePrd.exist(Sheet1.Range("A" & i).Value) <> True Then
dic_UniquePrd.Add Sheet1.Range("A" & i).Value, DestRwCntr
sheet2.Range("A" & int_DestRwCntr).Value = Sheet1.Range("A" & i).Value
sheet2.Range("B" & int_DestRwCntr).Value = Sheet1.Range("B" & i).Value
Else
sheet2.Range("A" & dic_UniquePrd.Item(Sheet1.Range("A" & i).Value)).Value = sheet2.Range("B" & dic_UniquePrd.Item(Sheet1.Range("A" & i).Value)).Value + Sheet1.Range("B" & i).Value
End If
Next
End Sub
This will serve the purpose..
Only thing to remember is to activate "Microsoft Scripting Runtimes" in references.
Based the code in Sub doIt(), is possible in the for Each ycle to retrive also the number of occurence?
Example:
Product # 101 have 4 occurence
Product # 102 have 2 occurence
ecc...
I know it' late... but I've been brought here by Sum up column B based on colum C values and so I post a solution with the same "formula" approach I used there but adapted to this actual need
Option Explicit
Sub main()
With ActiveSheet
With .Range("A:B").Resize(.cells(.Rows.Count, 1).End(xlUp).row) '<== here adjust "A:B" to whatever colums range you need
With .Offset(1).Resize(.Rows.Count - 1)
.Offset(, .Columns.Count).Resize(, 1).FormulaR1C1 = "=SUMIF(C1,RC1,C2)" ' "helper" column: it's the 1st column right of data columns (since ".Offset(, .Columns.Count)")
.Columns(2).Value = .Offset(, .Columns.Count).Resize(, 1).Value 'update "count" with sum-up from "helper" column
With .Offset(, .Columns.Count).Resize(, 1) ' reference to "helper" column
.FormulaR1C1 = "=IF(countIF(R1C1:RC1,RC1)=1,1,"""")" ' locate Product# repetition with blank cells
.Value = .Value 'fix values
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'delete rows corresponding to blank cells
.ClearContents ' clear "helper" column
End With
End With
End With
End With
End Sub
it makes use of a "helper" columns, which I assumed could be the one adjacent to the last data columns (i.e.: if data columns are "A:B" then helper column is "C")
should different "helper" column be needed then see comments about how it's located and change code accordingly