Related
How to get the address of selected multi rows?
When I press CTRL and multi select the specific rows, the result is will selected all the rows start from 1st specific row to last specific row, the rows I didn't select will be selected together if they are in 1st row to last row range.
Dim rng As Range: Set rng = Selection
MsgBox (rng.Address)
Picture added
Thank you.
On excel under developper step, u can save a macro.
Range("1:12,19:19,23:23,26:26").Select
Range("A26").Activate
t = Range("1:12,19:19,23:23,26:26").Address
t="$1:$12,$19:$19,$23:$23,$26:$26"
This is the result after select multi rows
$1:$12 => lines 1 to 12
$19:$19=> one other line selected
split t by , with a for each
in the loop split by :
...
Not 100% sure what you want to achive but I think the answer will be in here:
Option Explicit
Sub split_multi_address()
' note because the question asks about a selection on a sheet,
' fully qualified range names are not used
' as safe to assume we only want to operate on activesheet
Dim s As String
s = Selection.Address
Dim arrSplitStrings() As String
' array of range addresses as string
arrSplitStrings = Split(s, ",")
Dim v As Variant
For Each v In arrSplitStrings
Debug.Print v
Next v
' array of ranges
Dim arrSplitRanges() As Range
ReDim arrSplitRanges(UBound(arrSplitStrings) - LBound(arrSplitStrings))
Dim i As Long
i = 0
' create array of ranges
For Each v In Split(s, ",")
Set arrSplitRanges(i) = Range(v)
i = i + 1
Next v
' print array of ranges
For i = 0 To UBound(arrSplitRanges) - LBound(arrSplitRanges)
Debug.Print arrSplitRanges(i).Address
Next i
' array of ranges rows
' redim to remove previous values
ReDim arrSplitRanges(UBound(arrSplitStrings) - LBound(arrSplitStrings))
i = 0
' create array of range rows
For Each v In Split(s, ",")
Set arrSplitRanges(i) = Range(v).EntireRow
i = i + 1
Next v
' print array of ranges
For i = 0 To UBound(arrSplitRanges) - LBound(arrSplitRanges)
Debug.Print arrSplitRanges(i).Address
Next i
End Sub
Here is my Answer:
For DelRowAddr = 0 To i - 1
For RngProcAddr= 0 To j - 1 'The range only can delete the row
If ArrDelRow(DelRowAddr) = ArrProcRow(RngProcAddr) Then
DelTargetMatch = DelTargetMatch + 1
Else: Dismatch = Dismatch + 1
End If
If Dismatch = j Then 'Out of range
MsgBox DataFSC.Range("B5").Value & ArrDelRow(DelRowAddr), vbOKOnly + vbInformation, DataFSC.Range("A5") 'Error message in other sheet because some language can't show in vba
Exit Sub
End If
Next RngProcAddr
Dismatch = 0
Next DelRowAddr
Dim StrArrDelRow As String
StrArrDelRow = ""
If DelTargetMatch = i Then 'Maybe it is only the way to delete the row that I selected only
For DelRowAddr = 0 To i - 1
If DelRowAddr = i - 1 Then
StrArrDelRow = StrArrDelRow & Range(ArrDelRow(DelRowAddr)).Address
Else: StrArrDelRow = StrArrDelRow & Range(ArrDelRow(DelRowAddr)).Address & ","
End If
Next DelRowAddr
If Not StrArrDelRow = vbNullString Then
If Range(StrArrDelRow).Row = DeleteProcessOther.TopLeftCell.Row Then
MsgBox DataFSC.Range("B5").Value & ArrDelRow(DelRowAddr - 1), vbOKOnly + vbInformation, DataFSC.Range("A5")
Exit Sub
Else: Range(StrArrDelRow).EntireRow.Delete 'If I use this way to delete, it wont delete row5,7 as picture show
End If
Else: MsgBox DataFSC.Range("B5").Value & ArrDelRow(DelRowAddr - 1), vbOKOnly + vbInformation, DataFSC.Range("A5")
Exit Sub
End If
MsgBox ("¡Ì Deleted!") 'some special symbol or character can't show in vba
End If
Alright, this is a very specific question. I have an excel macro written that takes a web URL, delimits it, transposes it, and then adds adjacent columns that describe the information in the originally transposed columns. Now, I need to add something to my macro that will loop through and check if the first character of one cell matches one of the first 4 characters of another cell. If it does, I need to concatenate strings from the descriptive columns to new cells. I'll illustrate this below:
3,435,201,0.5,%22type%25202%2520diabetes%22,0 Node type 2 diabetes
4,165,97,0.5,%22diet%22,0 Node diet
5,149,248,0.5,%22lack%2520of%2520exercise%22,2 Node lack of exercise
6,289,329,0.5,%22genetics%22,3 Node genetics
7,300,71,0.5,%22blood%2520pressure%2520%22,5 Node blood pressure
7,3,-7,1,0 Arrow +
4,3,-21,1,0 Arrow +
5,3,-22,1,0 Arrow +
6,3,-34,1,0 Arrow +
,7%5D Tail
I added color to make the concept of the problem more easily visualized. In row one of the first column, we see a red 3 that corresponds to 'type 2 diabetes'. In the fifth row of the first column, we see a blue 7 that corresponds to 'blood pressure'. These are both node objects, as the adjacent column signifies. In the sixth cell of the first column we see a blue 7 and a red 3. This indicates that an arrow (also signified by adjacent column) is connecting blood pressure to diabetes. In the next column over, we see an orange plus sign, which indicates this is a positive relationship.
The goal is to populate the next column over with "blood pressure + type diabetes", as I demonstrated in the image. So, I need some code to check the first characters in each node cell, and then compare them to the first 4 characters of each arrow cell. When an arrow that matches two of the nodes is found, I need the code to populate the row next to the + signs with a concatenated string comprised of the names of the nodes pertaining to that arrow, as well as the + sign between them (it's possible that it could also be a minus sign, but one isn't present in this example). Any pointers? I can't wrap my head around this. Edited to add Data
Here is the code of my current macro:
Sub Delimit_Transpose()
Cells.Replace What:="],[", Replacement:="#", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.FormulaR1C1 = "=RIGHT(R[-1]C,LEN(R[-1]C)-36)"
Dim i As Long, strTxt As String
Dim startP As Range
Dim xRg As Range, yRg As Range
On Error Resume Next
Set xRg = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Delimit Transpose", Type:=8)
i = 1
Application.ScreenUpdating = False
For Each yRg In xRg
If i = 1 Then
strTxt = yRg.Text
i = 2
Else
strTxt = strTxt & "," & yRg.Text
End If
Next
Application.ScreenUpdating = True
Set startP = Application.InputBox _
(Prompt:="Paste Range...", _
Title:="Delimit Transpose", Type:=8)
ary = Split(strTxt, "#")
i = 1
Application.ScreenUpdating = False
For Each a In ary
startP(i, 1).Value = Replace(Replace(a, "[", ""), "]", "")
i = i + 1
Next a
i = 1
For Each a In ary
If Len(a) > 13 Then
startP.Offset(i - 1, 1).Value = "Node"
ElseIf Len(a) < 13 And Len(a) > 6 Then
startP.Offset(i - 1, 1).Value = "Arrow"
Else
startP.Offset(i - 1, 1).Value = "Tail"
End If
i = i + 1
Next a
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
i = 1
n = 5
For Each a In ary
openPos = InStr(a, ",%22")
On Error Resume Next
closePos = InStr(a, "%22,")
On Error Resume Next
midBit = Mid(a, openPos + 1, closePos - openPos - 1)
On Error Resume Next
If openPos <> 0 And Len(midBit) > 0 Then
startP.Offset(i - 1, 2).Value = Replace(Replace(midBit, "%22", ""), "%2520", " ")
ElseIf Len(a) < 13 And InStr(a, "-") = 4 Then
startP.Offset(i - 1, 2).Value = "'-"
ElseIf Len(a) < 7 Then
startP.Offset(i - 1, 2).Value = " "
Else
startP.Offset(i - 1, 2).Value = "+"
End If
i = i + 1
n = n + 1
Next a
Application.ScreenUpdating = True
End Sub
This is my approach.
There's room for a lot of improvements, but is a rough code that should get you started.
Read the code's comments and adapt it to fit your needs.
EDIT: I updated the code to match the sample worksheet you uploaded, build the first column range dinamically, validate if commas appear in the first column cell so no error is raised.
As I said in the comments, it's better easier to debug if you call one procedure from the other, instead of merging them.
Code:
Option Explicit
Public Sub StoreConcatenate()
' Basic error handling
On Error GoTo CleanFail
' Define general parameters
Dim targetSheetName As String
targetSheetName = "Test space" ' Sheet holding the data
Dim firstColumnLetter As String
firstColumnLetter = "C" ' First column holding the numbers
Dim firstColumnStartRow As Long
firstColumnStartRow = 7
' With these three parameters we'll build the range address holding the first column dynamically
' Set reference to worksheet
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
' Find last row in column (Modify on what column)
Dim firstColumnlastRow As Long
firstColumnlastRow = targetSheet.Cells(targetSheet.Rows.Count, firstColumnLetter).End(xlUp).Row
' Build range of first column dinamically
Dim firstColumnRange As Range
Set firstColumnRange = targetSheet.Range(firstColumnLetter & firstColumnStartRow & ":" & firstColumnLetter & firstColumnlastRow)
' Loop through first column range cells
Dim valueCell As Range
For Each valueCell In firstColumnRange
' Check if cell contains "," in the second position in string
If InStr(valueCell.Value, ",") = 2 Then
' Store first digit of cell before ","
Dim firstDigit As Integer
firstDigit = Split(valueCell.Value, ",")(0)
' Check if cell contains "," in the fourth position in string
If InStr(3, valueCell.Value, ",") = 4 Then
' Store second digit of cell after ","
Dim secondDigit As Integer
secondDigit = Split(valueCell.Value, ",")(1)
End If
' Store second colum type
Dim secondColumnType As String
secondColumnType = valueCell.Offset(, 1).Value
' Store third column value
Dim thirdColumnValue As String
thirdColumnValue = valueCell.Offset(, 2).Value
' Store nodes values (first digit and second column type)
Select Case secondColumnType
Case "Node"
Dim nodeValues() As Variant
Dim nodeCounter As Long
ReDim Preserve nodeValues(nodeCounter)
nodeValues(nodeCounter) = Array(firstDigit, thirdColumnValue)
nodeCounter = nodeCounter + 1
Case "Arrow"
Dim matchedNodeFirstValue As String
Dim matchedNodeSecondValue As String
matchedNodeFirstValue = IsInArrayReturnItem(firstDigit, nodeValues)(1)
matchedNodeSecondValue = IsInArrayReturnItem(secondDigit, nodeValues)(1)
If matchedNodeFirstValue <> vbNullString And matchedNodeSecondValue <> vbNullString Then
valueCell.Offset(, 3).Value = matchedNodeFirstValue & Space(1) & thirdColumnValue & Space(1) & matchedNodeSecondValue
End If
End Select
End If
Next valueCell
CleanExit:
Exit Sub
CleanFail:
Debug.Print "Something went wrong: " & Err.Description
Resume CleanExit
End Sub
' Credits: https://stackoverflow.com/a/38268261/1521579
Public Function IsInArrayReturnItem(stringToBeFound As Integer, arr As Variant) As Variant
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i)(0) = stringToBeFound Then
IsInArrayReturnItem = arr(i)
Exit Function
End If
Next i
IsInArrayReturnItem = Array(vbNullString, vbNullString)
End Function
Let me know if it works
It appears that you are concatenating the lookups based on the
first and second integers,
where the second column = "Arrow"
If that is the case, I suggest:
Read the data table into a VBA array for faster processing
I am assuming your data is ordered as you show it, with all the Node entries at the start.
if that is not the case, then loop twice -- once to find the Nodes, and second time to concatenate the Arrow data.
Read the diagnoses into a dictionary for fact lookup.
if column2 = "Arrow" then concatenate the lookups of the first and second integers
Write back the data
Note: As written, this will overwrite the original table destroying any formulas that might be there. If needed, you could easily modify it to only overwrite the necessary area.
Note2 Be sure to set a reference (under Tools/References) to Microsoft Scripting Runtime, or change the Dictionary declaration to late-binding.
Regular Module
'set reference to Microsoft Scripting Runtime
Option Explicit
Sub Dx()
Dim WS As Worksheet
Dim rngData As Range, c As Range, vData As Variant
Dim dDx As Dictionary
Dim I As Long, sKey As String, dxKeys As Variant
'Get the data range
Set WS = ThisWorkbook.Worksheets("sheet1")
With WS
'assume table starts in A1 and is three columns wide
Set rngData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
'read into variant array for faster processing
vData = rngData
End With
'create dictionsry for dx lookups
Set dDx = New Dictionary
For I = 2 To UBound(vData, 1)
Select Case vData(I, 2)
Case "Node"
sKey = Split(vData(I, 1), ",")(0) 'first comma-separated number
If dDx.Exists(sKey) Then
MsgBox "duplicate diagnostic key. Please correct the data"
Exit Sub
End If
dDx.Add Key:=sKey, Item:=vData(I, 3)
Case "Arrow"
dxKeys = Split(vData(I, 1), ",")
vData(I, 3) = dDx(dxKeys(0)) & " + " & dDx(dxKeys(1))
End Select
Next I
'reWrite the table
Application.ScreenUpdating = False
rngData = vData
End Sub
I'm looking for some sort of macro that deletes duplicate words within cells in a spreadsheet.
For instance, if cell A1 = "John John" I would like my macro to delete the duplicate "John". In other words A1 will become "John".
I have found a set of code that I have tweaked to some degree to fit my needs:
Sub Remove_DupesInString()
'this loops through the specified range and erases duplicates
Dim starval As String
Dim finval As String
Dim strarray() As String
Dim x As Long
Dim y As Long
Dim k As Long
' step through each cell in range
For Each cell In Sheets(5).Range("D2:D6507")
Erase strarray ' erase array
finval = "" ' erase final value"
starval = cell.Value
strarray = Split(starval, " ") 'Seperator is space
'Step through length of string and look for duplicate
For rw = 0 To UBound(strarray)
For k = rw + 1 To UBound(strarray)
If Trim(strarray(k)) = Trim(strarray(rw)) Then
strarray(k) = "" 'if duplicate clear array value
End If
Next k
Next rw
' combine all value in string less duplicate
For x = 0 To UBound(strarray)
If strarray(x) <> "" Then
finval = finval & Trim(strarray(x)) & ", "
End If
Next x
' remove last space and comma
finval = Trim(finval)
finval = Left(finval, Len(finval) - 1)
' Replaces cells with new values
cell.Value = finval
Next cell
End Sub
This set of code is sensitive to blank spaces in each cell. If, in cell D2, I have "John John" and in cell D3 have "Mary" it will produce the following:
D2 = "John", D3 = "Mary"
It does not seem to work, however, if I have blank cells in the column I'm running my macro in. I have worked around this issue by sorting on the cells with data inside them and only running my macro in this range.
I've tried tweaking the code further by adding different If cases with isEmpty(). My initial thought was that the the code above would only be executed If not isEmpty() Then but I've had no luck here. I'm not quite sure what to put inside the isEmpty function. Any ideas?
As you say, your only problem appears to be the handling of cells which are empty. That can easily be overcome by simply not processing any cells where the cell doesn't contain a space:
Sub Remove_DupesInString()
'this loops through the specified range and erases duplicates
Dim starval As String
Dim finval As String
Dim strarray() As String
Dim x As Long
Dim y As Long
Dim k As Long
' step through each cell in range
For Each cell In Sheets(5).Range("D2:D6507")
finval = "" ' erase final value"
starval = cell.Value
strarray = Split(starval, " ") 'Seperator is space
If UBound(strarray) > LBound(strarray) Then 'i.e. there was a space
'Step through length of string and look for duplicate
For rw = 0 To UBound(strarray)
For k = rw + 1 To UBound(strarray)
If Trim(strarray(k)) = Trim(strarray(rw)) Then
strarray(k) = "" 'if duplicate clear array value
End If
Next k
Next rw
' combine all value in string less duplicate
For x = 0 To UBound(strarray)
If strarray(x) <> "" Then
finval = finval & Trim(strarray(x)) & ", "
End If
Next x
' remove last space and comma
finval = Trim(finval)
finval = Left(finval, Len(finval) - 1)
' Replaces cells with new values
cell.Value = finval
End If
Next cell
End Sub
I have a workbook with cells that have linebreaks (entered via ALT + ENTER).
I have to separate them into individual rows. All the cells are in column A.
Each line in the cell has a bullet point (eg. "* ") up front, which could serve as a beacon to break the line at this point.
You can use split with Chr(10) or VbLf
Dim cell_value As Variant
Dim counter As Integer
'Row counter
counter = 1
'Looping trough A column define max value
For i = 1 To 10
'Take cell at the time
cell_value = ThisWorkbook.ActiveSheet.Cells(i, 1).Value
'Split cell contents
Dim WrdArray() As String
WrdArray() = Split(cell_value, vbLf)
'Place values to the B column
For Each Item In WrdArray
ThisWorkbook.ActiveSheet.Cells(counter, 2).Value = Item
counter = counter + 1
Next Item
Next i
No you have array to place each row to different cell
There is no need of code for this, lets make it simple.
Follow the bellow steps.
Select the data-set you want to split -> Go to Data Tab -> Select "Text to columns" -> from this pop-up select "Delimited" -> Select which delimiter is separating your texts -> Select the destination cell -> Click "OK"
Try This.
Regards,
Ashwin
Edit from Markus: For the newline as delimiter use "Ctr-J"
If you select the cell and run the macro you would get what you want on the next column like this:
Option Explicit
Public Sub selection_into_rows()
Dim k As Variant
Dim l_counter As Long
k = Split(Selection, Chr(10))
For l_counter = LBound(k) To UBound(k)
Cells(l_counter + 1, Selection.Column + 1) = k(l_counter)
Next l_counter
End Sub
This will work on one row only after selecting it (but should get you started):
Option Explicit
Public Sub SelectionIntoRows()
Dim k() As String
Dim l As Long
Dim i As Long
k() = Split(Range("A1"), " ")
i = 1
For l = 0 To UBound(k)
Cells(i, 1) = k(l)
i = i + 1
Next l
End Sub
Sub extract()
'Query extract data in cell B divided by ALT+Enter, Comma space
'Mandatory to create in front Sheet1, Sheet2, and Sheet3
'ATTENTION! if field B is empty return no data!! Manually add column A (with empty column B)if needed!!
'manually remove empty cell in results (Sheet2)
'before START Query remove duplicate from input data!!
'Doesn't work with full stop
'When finished Msg Done will be display
Dim c As Long, r As Range, I As Long, d As Long, Temp() As String
d = 0
For Each r In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row) ' Change this to suit your range..
c = 2
Temp = Split((r.Value), Chr(10))
For i = LBound(Temp) To UBound(Temp)
Sheets("Sheet2").Cells(r.Row, c - 1).Offset(d, 0).Value = Cells(r.Row, r.Column - 1).Value
Sheets("Sheet2").Cells(r.Row, c).Offset(d, 0).Value = Temp(i)
Cells(r.Row, c).Offset(d, 0).Select
ActiveCell.Value = Trim(ActiveCell.Value)
d = d + 1
Next
d = d - 1
Next
Sheets("Sheet2").Select
Columns("A:B").Select
ActiveSheet.Range("$A$1:$B$62856").RemoveDuplicates Columns:=Array(1, 2), _
Header:=xlYes
Range("A1").Select
I had a half dozen of these blobs from an poor Acrobat PDF to XLSX conversion, peppered throughout 500 rows.
I copied the text blob (like OP) into Notepad, removed "" from the start and end line, and pasted to a new spreadsheet. That tells me how many lines to insert. Then pasted into that hole.
"This was all of
my input text"
Then I could use TextToCol.
Suppose I have a column of arbitrary length where each cell contains a string of text. Is there a way to determine what words appear most frequently in the column (not knowing in advance which words to check) and subsequently order these words along with their frequencies in a two column table? Would VBA be best for this task?
As an example, a cell might contain the string "This is a string, and the # of characters inthis string is>0." (errors intentional)
Select a portion of column A and run this small macro ( the table will be placed in cols. B & C :
Sub Ftable()
Dim BigString As String, I As Long, J As Long, K As Long
BigString = ""
' Add code to sum both "All" and "all"
' Add code to separate "." "!" etc. from the word preceeding them so that word
' is also counted in the total. For example: "all." should not be reported as 1 ' "all." but "all" be added to the total count of "all" words.
' Would you publish this new code?
For Each r In Selection
BigString = BigString & " " & r.Value
Next r
BigString = Trim(BigString)
ary = Split(BigString, " ")
Dim cl As Collection
Set cl = New Collection
For Each a In ary
On Error Resume Next
cl.Add a, CStr(a)
Next a
For I = 1 To cl.Count
v = cl(I)
Cells(I, "B").Value = v
J = 0
For Each a In ary
If a = v Then J = J + 1
Next a
Cells(I, "C") = J
Next I
End Sub
Given this:
I'll use a pivot table to get this:
Best part is, if I got more, it's easy to get Top 5, 10, etc. And it'll always result to unique indices. From there, there are all manners of editing and calculation you can do. :)
Using Google Sheets:
index((Transpose(ArrayFormula(QUERY(TRANSPOSE(SPLIT(JOIN(" ",$B$2)," ")&{"";""}),"select Col1, count(Col2) group by Col1 order by count(Col2) desc limit 20 label Col1 'Word', count(Col2) 'Frequency'",0)))),1,$A6+1)&":"&index((Transpose(ArrayFormula(QUERY(TRANSPOSE(SPLIT(JOIN(" ",$B$2)," ")&{"";""}),"select Col1, count(Col2) group by Col1 order by count(Col2) desc limit 20 label Col1 'Word', count(Col2) 'Frequency'",0)))),2,$A6+1)
In the above $B$2 contains the text string
$A6 = 1 will give you the most used word
$A6 = 2 will give you the second most used word
etc.
This is set to do 20 most frequent. If you want more, increase the limit value to whatever you want.
Here's a tiny fix plus an enhancement to the script kindly offered by "Gary's Student". The fix is that while building the collection is apparently not case-sensitive (and this is correct--we probably don't want new items added to the collection that differ only in case from existing items), the IF statement that does the counting IS case-sensitive as written, so it doesn't count correctly. Just change that line to...
If LCase(a) = LCase(v) Then J = J + 1
And here's my enhancement. To use it, you first select one or more columns but NOT their (first) header/label rows. Then run the script, and it gives results for each selected column in a new worksheet--along with that header/label row so you know what you're looking at.
I'm just a dabbler. I just hack stuff when I need to get a job done, so it's not elegant, I'm sure...
Sub FrequencyV2() 'Modified from: https://stackoverflow.com/questions/21858874/counting-the-frequencies-of-words-in-excel-strings
'It determines the frequency of words found in each selected column.
'Puts results in new worksheets.
'Before running, select one or more columns but not the header rows.
Dim rng As Range
Dim row As Range
Dim col As Range
Dim cell As Range
Dim ws As Worksheet
Dim wsNumber As Long 'Used to put a number in the names of the newly created worksheets
wsNumber = 1
Set rng = Selection
For Each col In rng.Columns
Dim BigString As String, I As Long, J As Long, K As Long
BigString = ""
For Each cell In col.Cells
BigString = BigString & " " & cell.Value
Next cell
BigString = Trim(BigString)
ary = Split(BigString, " ")
Dim cl As Collection
Set cl = New Collection
For Each a In ary
On Error Resume Next 'This works because an error occurs if item already exists in the collection.
'Note that it's not case sensitive. Differently capitalized items will be identified as already belonging to collection.
cl.Add a, CStr(a)
Next a
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = "F" & CStr(wsNumber)
wsNumber = wsNumber + 1
Worksheets(ws.Name).Cells(1, "A").Value = col.Cells(1, 1).Offset(-1, 0).Value 'Copies the table header text for current column to new worksheet.
For I = 1 To cl.Count
v = cl(I)
Worksheets(ws.Name).Cells(I + 1, "A").Value = v 'The +1 needed because header text takes up row 1.
J = 0
For Each a In ary
If LCase(a) = LCase(v) Then J = J + 1
Next a
Worksheets(ws.Name).Cells(I + 1, "B") = J 'The +1 needed because header text takes up row 1.
Next I
Next col
End Sub