I try to name cells with a macro in Excel. Here is the code :
Sub setHeader()
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Cell As Range
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
i = 0
j = 0
k = 0
l = 0
Dim MyColumnRange As Range
Dim MyRowRange As Range
Dim MyCellRange As Range
Set MyColumnRange = ActiveSheet.Range("E7:V8")
Set MyRowRange = ActiveSheet.Range("B10:B16")
Set MyCellRange = ActiveSheet.Range("E10:V16")
Dim MyColumnName As String
Dim MyRowName As String
Dim MyCellName As String
MyColumnName = "HC_"
MyRowName = "HL_"
MyCellName = "?"
For Each Cell In MyRowRange
Cell.Name = MyRowName + CStr(j)
j = j + 1
Next Cell
For Each Cell In MyColumnRange
If Not IsEmpty(Cell.Value) Then
Cell.Name = MyColumnName + CStr(i)
i = i + 1
End If
Next Cell
For Each Cell In MyCellRange
Cell.Name = MyRowName + CStr(k) + MyCellName + MyColumnName + CStr(l)
If l = (MyCellRange.Columns.Count - 1) Then
l = 0
k = k + 1
Else
l = l + 1
End If
Next Cell
End Sub
I works well for the naming in MyColumnRange and MyCellRange, but for MyRowRange I have the error
"method name of object range failed"
and I do not understand why.
When you are naming cells in MyRowRange:
For Each Cell In MyRowRange
Cell.Name = MyRowName + CStr(i)
j = j + 1
Next Cell
You are naming them with your terribly named variable i but you are incrementing terribly named variable j. Probably you mean Cell.Name = MyRowName + Cstr(j)
so, you don't really need to convert to string, try using & instead of + like this example :
For j = 1 to MyRowRange.cells.count
MyRowRange.cells(j).Name = MyRowName & j
Next j
i changed your for each loop (wich is fine), just for an example of an other way to do it...
Related
I have the follow code to fill cells in excel one by one and it works the way I want it to but it gives me this error when it runs through the array. How do I fix this error? Thanks
The error is "Subscript out of range. Error: 9"
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
Cells(i, 1) = finalSplit(0)
Cells(i, 2) = finalSplit(1)
Cells(i, 3) = finalSplit(2)
Cells(i, 4) = finalSplit(3)
i = i + 1
s = s + 1
Next
I checked if finalSplit contains enough values like Thomas said and it worked.This is the new code below.
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
If UBound(finalSplit) > 1 Then
Cells(i, 1) = finalSplit(0)
Cells(i, 2) = finalSplit(1)
Cells(i, 3) = finalSplit(2)
Cells(i, 4) = finalSplit(3)
i = i + 1
s = s + 1
End If
Next
As other commenters have pointed out, why not add another control variable?
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
Dim i As Integer, j As Integer, s As Integer
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
For j = 0 To UBound(finalSplit)
Cells(i, j + 1) = finalSplit(j)
Next j
i = i + 1
s = s + 1
Next
Be aware that this can loop more than the 4 times you expect. A lazy way to solve this would be to add If j > 3 Then Exit For before Next j
I tested this with the following code (it works!), as I have no idea what splitString() or finalSplit() is in your case:
Sub test()
Dim finalSplit As Variant
Dim j As Integer
finalSplit = Split("1,2,3,4,5", ",")
For j = 0 To UBound(finalSplit)
Cells(1, j + 1) = finalSplit(j)
If j > 3 Then Exit For
Next j
End Sub
Looping Through Elements of Arrays
An array created by the Split function is always 0-based (even if Option Base 1). Similarly, not quite related, an array created by the Array function is dependent on Option Base unless you use its parent VBA e.g. arr = VBA.Array(1,2,3). Then it is always zero-based.
Looping through the elements of an array (1D array) is done in the following two ways:
For Each...Next
Dim Item As Variant
For Each Item In Arr
Debug.Print Item
Next Item
For...Next
Dim i As Long
For i = LBound(Arr) To Ubound(Arr)
Debug.Print Arr(i)
Next i
Since we have established that Split always produces a zero-based array, in the second example we could use 0 instead of LBound(Arr):
`For...Next`
Dim i As Long
For i = 0 To Ubound(Arr)
Debug.Print Arr(i)
Next i
Option Explicit
Sub DoubleSplit()
Const IniString As String = "A,B,C,D/E,F,G,H/I,J,K/L/M,N,O,P,Q,R"
Dim SplitString() As String: SplitString = Split(IniString, "/")
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
ws.Cells.ClearContents ' remove previous data; clears the whole worksheet
Dim FinalSplit() As String
Dim Item As Variant ' SplitString Control Variable
Dim r As Long ' Worksheet Row Counter
Dim f As Long ' FinalSplit Element Counter
' For Each...Next
For Each Item In SplitString
r = r + 1
FinalSplit = Split(Item, ",")
Debug.Print Join(FinalSplit, ",")
For f = 0 To UBound(FinalSplit)
ws.Cells(r, f + 1).Value = FinalSplit(f)
Next f
Next Item
r = r + 1 ' add an empty row
Dim s As Long ' SplitString Element Counter
' For...Next
For s = 0 To UBound(SplitString)
r = r + 1
FinalSplit = Split(SplitString(s), ",")
Debug.Print Join(FinalSplit, ",")
For f = 0 To UBound(FinalSplit)
ws.Cells(r, f + 1).Value = FinalSplit(f)
Next f
Next s
' Results
' A,B,C,D
' E,F,G,H
' I,J,K
' L
' M,N,O,P,Q,R
'
' A,B,C,D
' E,F,G,H
' I,J,K
' L
' M,N,O,P,Q,R
End Sub
I am trying to work out the looping on my script but have found it difficult to figure out. I am using this script to find matching data from different sources and reference them together. I would use the built-in functions in excel but it doesn't care about finding the same data more than once.
Read the titles of all the spreadsheets in the book. #Works
Make an array with those titles #Works
Filter out the "current" sheet #Works
Reference each cell in column A on "current" sheet against all the cells on all the pages in column H #Works
If it matches one, take the data from the page it was found on and the data in column G then set that as the value on "current" page in column E #Works
Make the next page in the main sheet array the "current" page and do it all over again #Doesn't Work
I didn't think this would be as complicated as it is, and maybe I'm not helping by not using functions. Got any idea on how to advance inspectSheet correctly?
Sub listsheets()
Dim ws As Worksheet
Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim sheetArray() As Variant
x = 0
y = 0
i = 0
For Each ws In Worksheets
ReDim Preserve sheetArray(i)
sheetArray(i) = ws.Name
i = i + 1
Next ws
Do Until i = 1
i = i - 1
inspectSheet = sheetArray(x)
column = Sheets(inspectSheet).Cells(Rows.Count, "A").End(xlUp).Row
matchArray = Filter(sheetArray, inspectSheet, False, vbTextCompare)
HOLDER = Join(matchArray)
matchSheet = matchArray(y)
Do Until column = 1
currentCell = Sheets(inspectSheet).Cells(column, 1).Value
checkListLength = Sheets(matchSheet).Cells(Rows.Count, "H").End(xlUp).Row
Do Until checkListLength = 1
matchCell = Sheets(matchSheet).Cells(checkListLength, 8).Value
Debug.Print "Checking: " + currentCell + " on " + inspectSheet + " against " + matchCell + " from page " + matchSheet
If currentCell = matchCell Then
Sheets(inspectSheet).Cells(column, 5).Value = matchSheet + " on " + Sheets(matchSheet).Cells(checkListLength, 7).Value
End If
checkListLength = checkListLength - 1
Loop
column = column - 1
Loop
y = y + 1
Loop
x = x + 1
End Sub
I see you already answered your own question, but here's a slightly different approach with fewer counters to track:
Sub listsheets()
Dim wsMatch As Worksheet, wsInspect As Worksheet
Dim currVal
Dim cInspect As Range, cMatch As Range, rngMatch As Range, rngInspect As Range
For Each wsInspect In ThisWorkbook.Worksheets
Set rngInspect = wsInspect.Range("A1:A" & wsInspect.Cells(Rows.Count, "A").End(xlUp).Row)
For Each wsMatch In ThisWorkbook.Worksheets
If wsMatch.Name <> wsInspect.Name Then 'filter out same-name pairs...
Set rngMatch = wsMatch.Range("H1:H" & wsMatch.Cells(Rows.Count, "H").End(xlUp).Row)
For Each cInspect In rngInspect.Cells
currVal = cInspect.Value
For Each cMatch In rngMatch.Cells
If cMatch.Value = currVal Then
cInspect.EntireRow.Columns("E").Value = _
wsMatch.Name & " on " & cMatch.Offset(0, -1).Value
End If
Next cMatch
Next cInspect
End If 'checking these sheets
Next wsMatch
Next wsInspect
End Sub
I got it, I was not resetting my counter variables and needed one more external loop to advance. The finished code is:
Sub listsheets()
Dim ws As Worksheet
Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim limit As Integer
Dim sheetArray() As Variant
x = 0
y = 0
i = 0
For Each ws In Worksheets
ReDim Preserve sheetArray(i)
sheetArray(i) = ws.Name
i = i + 1
Next ws
limit = UBound(sheetArray)
Do Until x = limit
Do Until i = 1
i = i - 1
inspectSheet = sheetArray(x)
Column = Sheets(inspectSheet).Cells(Rows.Count, "A").End(xlUp).Row
matchArray = Filter(sheetArray, inspectSheet, False, vbTextCompare)
HOLDER = Join(matchArray)
matchSheet = matchArray(y)
Do Until Column = 1
currentCell = Sheets(inspectSheet).Cells(Column, 1).Value
checkListLength = Sheets(matchSheet).Cells(Rows.Count, "H").End(xlUp).Row
Do Until checkListLength = 1
matchCell = Sheets(matchSheet).Cells(checkListLength, 8).Value
Debug.Print "Checking: " + currentCell + " on " + inspectSheet + " against " + matchCell + " from page " + matchSheet
If currentCell = matchCell Then
Sheets(inspectSheet).Cells(Column, 5).Value = matchSheet + " on " + Sheets(matchSheet).Cells(checkListLength, 7).Value
End If
checkListLength = checkListLength - 1
Loop
Column = Column - 1
Loop
y = y + 1
Loop
i = UBound(sheetArray)
y = 0
x = x + 1
Loop
End Sub
I have 6 sheets in an Excel document.
I would like to compare two sheets.
Sheet 1 (Artikelstammdaten) has 8555 Lines
Sheet 2 (Warengruppen) has 232 Lines
My Code:
Sub WorksheetLoop()
Dim Current As Range
Dim Element As Range
Dim wgRow As Integer
Dim wbRow As Integer
Dim Warengruppe As String
Dim Warengruppebezeichnung As String
Dim Stamm1 As String
Dim Stamm2 As String
Dim Stamm3 As String
Dim Summe As String
wgRow = 2
wbRow = 2
For Each Element In Sheets("Artikelstammdaten").Range("R:R")
Warengruppebezeichnung = Sheets("Warengruppen").Cells(wbRow, 1).Value
Warengruppe = Sheets("Artikelstammdaten").Cells(wgRow, 18).Value
If Warengruppe = Warengruppebezeichnung Then
Stamm1 = Sheets("Warengruppen").Cells(wbRow, 2).Value
Stamm2 = Sheets("Warengruppen").Cells(wbRow, 3).Value
Stamm3 = Sheets("Warengruppen").Cells(wbRow, 4).Value
Summe = Stamm1 + ">" + Stamm2 + ">" + Stamm3
Sheets("Artikelstammdaten").Cells(wgRow, 18).Value = Summe
wbRow = 2
wgRow = wgRow + 1
Else
wbRow = wbRow + 1
End If
Next
End Sub
It works but breaks off at line 1755.
The reason you got only 1755 iterations is that you waste many loops to find the matching value in Sheets("Warengruppen"). Use a wiser way, Range.Find(What:=key) method returns a range object with the same key. Note it will return Nothing if nothing is matched, so we need to check if it is found or not for preventing an error.
Sub WorksheetLoop()
'current is crying because you never call her :/
Dim Current As Range
Dim Element As Range
Dim wbFound As Range
Dim Stamm1 As String
Dim Stamm2 As String
Dim Stamm3 As String
Dim Summe As String
For Each Element In Sheets("Artikelstammdaten").Range("R:R")
Set wbFound = Sheets("Warengruppen").Range("A:A").Find(What:=Element.Value)
If wbFound Is Nothing Then
Debug.Print "Not Found with Row# " & Element.Row
Else
Stamm1 = wbFound.Offset(0, 1)
Stamm2 = wbFound.Offset(0, 2)
Stamm3 = wbFound.Offset(0, 3)
Summe = Stamm1 + ">" + Stamm2 + ">" + Stamm3
Element.Value = Summe
End If
Next Element
End Sub
The below Code Counts the number of unique names is a specific column after inputting the data into an array. It works perfectly when running in the the immediate window. But when using as a UDF it throws #Value Error. I am taking all the data into an array and checking the array and getting a number out of it and returning it. I am not modifying any excel sheets or changing the worksheet's environment. Please help!!1
Public Function Operator_Count(Aircraft As String) As Integer
Dim Aircraft_Name As String
Dim Data_Array() As Variant
Dim Row_Count As Integer
Dim Col_Count As Integer
Dim Col_Alph As String
Dim Row_Counter As Integer
Dim Master_Series_Column As Integer
Dim Status_Column As Integer
Dim Operator_Column As Integer
Dim InnerLoop_Counter As Integer
Dim Operator_Array() As Variant
Dim Operator_Array_Transpose() As Variant
Dim Array_Counter As Integer
Aircraft_Name = Aircraft
Operator_Count = 0
'ThisWorkbook.Sheets("Aircraft Data").Activate
Row_Count = ThisWorkbook.Sheets("Aircraft Data").Range("A2", Range("A2").End(xlDown)).Rows.Count
Col_Count = ThisWorkbook.Sheets("Aircraft Data").Cells(1, Columns.Count).End(xlToLeft).Column
Col_Alph = ColumnLetter(Col_Count)
Data_Array = ThisWorkbook.Sheets("Aircraft Data").Range("A1:" & Col_Alph & Row_Count + 1).Value2
For Row_Counter = 1 To Col_Count
If Data_Array(1, Row_Counter) = "Master Series" Then
Master_Series_Column = Row_Counter
End If
Next
For Row_Counter = 1 To Col_Count
If Data_Array(1, Row_Counter) = "Status" Then
Status_Column = Row_Counter
End If
Next
For Row_Counter = 1 To Col_Count
If Data_Array(1, Row_Counter) = "Operator" Then
Operator_Column = Row_Counter
End If
Next
'Resizing the data array
ReDim Operator_Array(0, 0)
'Adding column to the data array
InnerLoop_Counter = 0
For Row_Counter = 1 To UBound(Data_Array)
If Data_Array(Row_Counter, Master_Series_Column) = Aircraft_Name And (Data_Array(Row_Counter, Status_Column) = "In Service" Or Data_Array(Row_Counter, Status_Column) = "On order") Then
Flag = 0
For Array_Counter = 0 To UBound(Operator_Array, 2)
If Operator_Array(0, Array_Counter) = Data_Array(Row_Counter, Operator_Column) Then
Flag = 1
Array_Counter = UBound(Operator_Array, 2)
End If
Next
If Flag <> 1 Then
ReDim Preserve Operator_Array(0, InnerLoop_Counter)
Operator_Array(0, InnerLoop_Counter) = Data_Array(Row_Counter, Operator_Column)
InnerLoop_Counter = InnerLoop_Counter + 1
End If
End If
Next
Operator_Count = UBound(Operator_Array, 2)
End Function
Function ColumnLetter(ColumnNumber As Integer) As String
Dim n As Integer
Dim c As Byte
Dim s As String
n = ColumnNumber
Do
c = ((n - 1) Mod 26)
s = Chr(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
ColumnLetter = s
End Function
I have a column of about 50 cells. Each cell contains a block of text, anywhere from 3-8 sentences.
Id like to populate a list of words being used and obtain their frequencies for the entire range (A1:A50).
Ive tried to manipulate other codes I've found in other posts but they seem to be tailored to cells that contain one word rather than multiple words.
This is the code I found that I was attempting to use.
Sub Ftable()
Dim BigString As String, I As Long, J As Long, K As Long
Dim Selection As Range
Set Selection = ThisWorkbook.Sheets("Sheet1").Columns("A")
BigString = ""
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)
ThisWorkbook.Sheets("Sheet2").Cells(I, "B").Value = v
J = 0
For Each a In ary
If a = v Then J = J + 1
Next a
ThisWorkbook.Sheets("Sheet2").Cells(I, "C") = J
Next I
End Sub
Here you go, a dictionary is the best way to handle this I think as you can test if the dictionary already contains an item. Post back if there's anything you don't get.
Sub CountWords()
Dim dictionary As Object
Dim sentence() As String
Dim arrayPos As Integer
Dim lastRow, rowCounter As Long
Dim ws, destination As Worksheet
Set ws = Sheets("Put the source sheet name here")
Set destination = Sheets("Put the destination sheet name here")
rowCounter = 2
arrayPos = 0
lastRow = ws.Range("A1000000").End(xlUp).Row
Set dictionary = CreateObject("Scripting.dictionary")
For x = 2 To lastRow
sentence = Split(ws.Cells(x, 1), " ")
For y = 0 To UBound(sentence)
If Not dictionary.Exists(sentence(y)) Then
dictionary.Add sentence(y), 1
Else
dictionary.Item(sentence(y)) = dictionary.Item(sentence(y)) + 1
End If
Next y
Next x
For Each Item In dictionary
destination.Cells(rowCounter, 1) = Item
destination.Cells(rowCounter, 2) = dictionary.Item(Item)
rowCounter = rowCounter + 1
Next Item
End Sub
Try this (works for me with some long blocks of Lorem Ipsum text):
Sub Ftable()
Dim BigString As String, I As Long, J As Long, K As Long
Dim countRange As Range
Set countRange = ThisWorkbook.Sheets("Sheet1").Range("A1:A50")
BigString = ""
For Each r In countRange.Cells
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)
ThisWorkbook.Sheets("Sheet2").Cells(I, "B").Value = v
J = 0
For Each a In ary
If a = v Then J = J + 1
Next a
ThisWorkbook.Sheets("Sheet2").Cells(I, "C") = J
Next I
End Sub
I took it down to only looking at the 50 cells where you have data, as opposed to all >1 million in that column. I also fixed an issue where r was getting a length 1 array instead of a Range. And I renamed "Selection" to "countRange" because Selection is already defined in the application, so it was bad naming.
Also, notice that your code pulls from "Sheet1" and outputs into columns B and C of "Sheet2". Make sure you rename your worksheets or edit these values, or you'll get errors/data corruption.
This is how I'd approach the problem:
Sub Ftable()
Dim wordDict As New Dictionary
Dim r As Range
Dim countRange As Range
Dim str As Variant
Dim strArray() As String
Set countRange = ThisWorkbook.Sheets("Sheet1").Range("A1:A50")
For Each r In countRange
strArray = Split(Trim(r.Value), " ")
For Each str In strArray
str = LCase(str)
If wordDict.Exists(str) Then
wordDict(str) = wordDict(str) + 1
Else
wordDict.Add str, 1
End If
Next str
Next r
Set r = ThisWorkbook.Sheets("Sheet2").Range("B1")
For Each str In wordDict.Keys()
r.Value = str
r.Offset(0, 1).Value = wordDict(str)
Set r = r.Offset(1, 0)
Next str
Set wordDict = Nothing
End Sub
It uses a dictionary, so make sure you add a reference to the library (Tools > Add Reference > Microsoft Scripting Library). It also forces everything to lowercase - one big issue of the old code was that it failed to count capitalized and uncapitalized versions correctly, meaning it missed many words. Remove str = LCase(str) if you don't want this.
Bonus: this method ran about 8 times faster on my test sheet.