I've got the following question:
This line wsMotiv.Range("motiv_naam") = Cells(iRijnummer, iKolomnrNaam).Text gives a name (string) value. Why doesn't the line s = ThisWorkbook.Worksheets(1).Cells(iRijnummer, iKolomnrNaam).Text do the same? It passes " ".
Sub (whatev)
AantalZichtbareRows
Dim rng As Range
Dim row As Range
Dim StrFileName As String
'If Aantalregels > 1 Then
Set rng = Selection.SpecialCells(xlCellTypeVisible)
For Each row In rng.Rows
iRijnummer = row.row
If iRijnummer > 1 Then
Windows(c_SourceDump).Activate
wsMotiv.Range("motiv_cid") = Cells(iRijnummer, iKolomnrCorpID).Text
wsMotiv.Range("motiv_naam") = Cells(iRijnummer, iKolomnrNaam).Text
wsMotiv.Range("motiv_ldg") = Cells(iRijnummer, iKolomnrHuidigeLeidingGevende).Text
Worksheets("stambestand").Activate
'naamOpmaken
Dim s As String: s = ThisWorkbook.Worksheets(1).Cells(iRijnummer, iKolomnrNaam).Text
Dim Position As Long, Length As Long
Dim n As String
Position = InStrRev(s, " ")
Length = Len(s)
n = Right(s, Length - Position)
End If
Next row
End Sub
You are referring to the ActiveSheet in Cells(iRijnummer, iKolomnrNaam).Text and to the first worksheet in ThisWorkbook.Worksheets(1).Cells(iRijnummer, iKolomnrNaam).Text. Probably they are different. Try this to see:
Sub TestMe
Debug.Print wsMotiv.Name
Debug.Print Worksheets(1).Name
Debug.Print ActiveSheet.Name
End Sub
Related
Why is it not working?
Prints only the first word and I don't know how I can change "10" in "For" on something like "For each word in sentence"
Sub Change()
Dim S As String
Dim i As Integer
Dim x As String
S = InputBox("Sentence")
x = Split(S, " ")
For i = 1 To x
Cells(1, i).Value = Split(S, " ")
Next i
End Sub
Try this:
Public Sub Change()
Dim sentence As String: sentence = InputBox("Sentence")
Dim col As Long: col = 1
Dim word As Variant: For Each word In Split(sentence, " ")
ThisWorkbook.Worksheets("Sheet1").Cells(1, col).Value = word
col = col + 1
Next
End Sub
Split Sentence to Worksheet
Option Explicit
Sub SentenceToRow()
Const ProcTitle As String = "Sentence to Row"
Const First As String = "A1"
Dim S As Variant: S = InputBox("Input a Sentence", ProcTitle)
If Len(S) = 0 Then
MsgBox "You canceled.", vbExclamation, ProcTitle
Exit Sub
End If
Dim Strings() As String: Strings = Split(S)
Dim cCount As Long: cCount = UBound(Strings) + 1
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range(First).Resize(, cCount)
rg.Value = Strings
MsgBox "Sentence split to a row.", vbInformation, ProcTitle
End Sub
Sub SentenceToColumn()
Const ProcTitle As String = "Sentence to Column"
Const First As String = "A1"
Dim S As Variant: S = InputBox("Input a Sentence", ProcTitle)
If Len(S) = 0 Then
MsgBox "You canceled.", vbExclamation, ProcTitle
Exit Sub
End If
Dim Strings() As String: Strings = Split(S)
Dim rCount As Long: rCount = UBound(Strings) + 1
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range(First).Resize(rCount)
rg.Value = Application.Transpose(Strings)
MsgBox "Sentence split to a column.", vbInformation, ProcTitle
End Sub
this is fast and eficient:
Sub testSplit2Row()
Dim frase As String
frase = "las palabras de amor"
Dim ary As Variant
ary = Split(frase, " ")
Dim dest As Range
Dim start As Range
Set start = Range("B1")
Set dest = start.Resize(UBound(ary) + 1)
dest.Value = Application.Transpose(ary)
start.Resize(, UBound(ary) + 1).Value = ary
End Sub
If you dispose of the dynamic array functions of MSExcel 365, you might profit from the following function, usable as well as udf or via code.
The function words() accepts range values, array values or explicit string inputs as first argument s; the second argument IsVertical is optional and indicates that results will be returned as vertical array by default (instead of a "flat" array).
Public Function words(ByVal s As Variant, Optional IsVertical As Boolean = True)
'Debug.Print VarType(s)
If VarType(s) >= vbArray Then
s = Replace(Application.WorksheetFunction.ArrayToText(s), ",", "")
End If
words = Split(s)
If IsVertical Then
words = Application.WorksheetFunction.Transpose(Split(s))
End If
End Function
a) Example using a multi-row range input in B2
=words(A2:A4)
b) Example call via code
Option Explicit ' module head of code module
Sub ExampleCall
With Sheet1
Dim wds As Variant
wds = words(.Range("A2:A4"))
.Range("A10").Resize(UBound(wds), UBound(wds, 2)) = wds
End With
End Sub
If you intend, however to display results horizontally, just code as follows (note the dimension change!):
'...
wds = words(.Range("a2:a4"), False) ' False returns "flat" 1-dim array
.Range("A10").Resize(1, UBound(wds)) = wds
I would like to create the table based on the "Header" name and it's last row of the table.
I could found the Header start address and Length of the table also using some formulas.
For Example:
FindHeaderValue as 14 i.e, $B$14
TableLength as 65, i.e, $V$65
Hence, I would like to create the Table with the range for
$B$FindHeaderValue:$V$TableLength .
Because the FindHeaderValue and TableLength will vary Excel to Excel.
Please help to figure out the solution for the same. Thank you so much in advance.
Sub Test()
Dim sFindHeader As String
Dim oRangeFindHeader As Range, FirstRange As String, LastRange As String
Dim FindHeaderValue As Integer, FindLength As Integer, TableLength As Integer
Dim Ws As Worksheet
Set Ws = ThisWorkbook.Sheets("Sheet1")
Set oRangeFindHeader = Worksheets("8A52").Range("B1:V5000").Find("BBBB", lookat:=xlPart)
sFindHeader = oRangeFindHeader.Address(ReferenceStyle:=xlR1C1)
FindHeaderValue = GetNumber(sFindHeader)
FirstRange = oRangeFindHeader.Address
MsgBox FindHeaderValue
MsgBox FirstRange
FindLength = FindHeaderValue + 2
TableLength = Cells(FindLength, 13).End(xlDown).Row
MsgBox TableLength
Ws.ListObjects.Add(xlSrcRange, Ws.Range("$B$FindHeaderValue:$V$TableLength"), , xlYes).Name = "DefinitionTable"
Ws.ListObjects("DefinitionTable").TableStyle = "TableStyleLight1"
End Sub
Public Function GetNumber(s As String) As Long
Dim b As Boolean, i As Long, t As String
b = False
t = ""
For i = 1 To Len(s)
If IsNumeric(Mid(s, i, 1)) Then
b = True
t = t & Mid(s, i, 1)
Else
If b Then
GetNumber = CLng(t)
Exit Function
End If
End If
Next i
End Function
Variables don't belong inside quotes. Use & to concatenate them into the range address (which doesn't need $ by the way):
Ws.Range("B" & FindHeaderValue & ":V" & TableLength)
I have a sub which adds a column from a table to an array (strArr), loops through the array to determine which rows to delete, and adds the row I want to delete to another array (deleteArr). I then loop in reverse order to delete the row. It seems to work fine for a small number of rows, but completely hangs on rows where I have a few thousand matches in deleteArr, even if I let it run forever. Does anyone have an idea what is going on here?
Public Sub DeleteRows(ByVal surveyString As String)
Dim surveyArr() As String
Dim retireArr() As String
Dim strArr() As Variant
Dim deleteArr() As Variant
Dim totalRows As Long
Dim tRange As String
Dim x As Long
Dim y As Long
Dim ws As Worksheet
'Split up fields to delete received from listBox
If surveyString <> "" Then
surveyArr = Split(surveyString, "|")
End If
totalRows = Sheets("Employee").Rows(Rows.Count).End(xlUp).Row
tRange = "L2:L" & CStr(totalRows)
strArr = Sheets("Employee").Range(tRange).Value
x = 0
If surveyString <> "" Then
'determine which rows match and need to be deleted
'the value in deleteArr is the row to delete
For i = 1 To UBound(strArr)
For i2 = 0 To UBound(surveyArr)
If strArr(i, 1) = surveyArr(i2) Then
'resize the array and add the row value of what we want to delete
ReDim Preserve deleteArr(0 To x)
deleteArr(x) = i + 1
x = x + 1
End If
Next i2
Next i
'delete the row in reverse order so no rows are skipped
Set ws = Sheets("Employee")
y = UBound(deleteArr)
For i = totalRows To 2 Step -1
If i = deleteArr(y) Then
ws.Rows(i).EntireRow.Delete
If y > 0 Then
y = y - 1
End If
End If
Next i
End If
End Sub
You could try to union a range of all rows you want to delete, then delete in one shot. Code is untested, hopefully this points you in the right direction.
Public Sub DeleteRows(ByVal surveyString As String)
Dim surveyArr() As String
Dim retireArr() As String
Dim strArr() As Variant
Dim deleteArr() As Variant
Dim totalRows As Long
Dim tRange As String
Dim x As Long
Dim y As Long
Dim ws As Worksheet
Dim UnionRange As Range
'Split up fields to delete received from listBox
If surveyString <> "" Then
surveyArr = Split(surveyString, "|")
End If
totalRows = Sheets("Employee").Rows(Rows.Count).End(xlUp).Row
tRange = "L2:L" & CStr(totalRows)
strArr = Sheets("Employee").Range(tRange).Value
Set ws = Sheets("Employee")
If surveyString <> "" Then
'determine which rows match and need to be deleted
'the value in deleteArr is the row to delete
For i = 1 To UBound(strArr)
For i2 = 0 To UBound(surveyArr)
If strArr(i, 1) = surveyArr(i2) Then
If UnionRange Is Nothing Then
Set UnionRange = ws.Rows(i)
Else
Set UnionRange = Union(UnionRange, ws.Rows(i))
End If
End if
Next
Next
If Not UnionRange Is Nothing Then UnionRange.EntireRow.Delete
End If
End Sub
I have a column range of about 500 rows. Most of those cells are stored as text. I populate a listbox on a userform with the values from that range. When a user selects one of those values from the listbox an event will find the value on the same row from another column using Index and Match and display it in a label on the userform. I get an error when selecting one of the few cells in the listbox that are not stored as text in the range because there is a leading space. I am assuming that the populated listbox automatically removes leading spaces from any cells in the range. Therefore, when it tries to find value 12345 from the listbox, for example, in the range it can't find it because the range contains (space)12345. I have tried:
Public Sub UserForm_Initialize()
Dim arr() As Variant
Dim rNum As Range
Const sNum As String = "Number"
Me.EnableEvents = False
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pReport
If .AutoFilterMode = True Then .ShowAllData
.Cells.Rows.Hidden = False
.Cells.Columns.Hidden = False
End With
Set wf = Application.WorksheetFunction
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
End With
-- HERE is where I tried all my implementations without success
arr = wf.Transpose(pReport.Range(rNum.address).Value)
Call BubbleSort(arr)
frmIssues.lstIssues1.List = arr
lstIssues1.ListStyle = 1
lstIssues2.ListStyle = 1
lstIssues1.MultiSelect = 2
lstIssues2.MultiSelect = 2
txtFocus.SetFocus
Me.EnableEvents = True
End Sub
Private Sub lstIssues1_Change()
Dim rNum As Range
Dim rTitle As Range
Dim strResult As String
Dim intIndex As Integer
Dim intCount As Integer
Const sNum As String = "Number"
Const sTitle As String = "Title"
If EnableEvents = False Then Exit Sub
With lstIssues1
For intIndex = 0 To .ListCount - 1
If .Selected(intIndex) Then intCount = intCount + 1
Next
End With
If intCount = 1 Then
Set wf = Application.WorksheetFunction
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
Set rTitle = .ListColumns(.ListColumns(sTitle).Range.column).DataBodyRange
End With
With pReport
strResult = wf.Index(.Range(rTitle.address), wf.Match(lstIssues1.List(lstIssues1.ListIndex), .Range(rNum.address), 0))
End With
lblDescription.Caption = wf.Trim(strResult)
txtFocus.SetFocus
Else
lblDescription.Caption = ""
txtFocus.SetFocus
Exit Sub
End If
Me.EnableEvents = False
For i = 0 To lstIssues2.ListCount - 1
If lstIssues2.Selected(i) = True Then lstIssues2.Selected(i) = False
Next
Me.EnableEvents = True
End Sub
and numerous variations of it (Clean, CStr, .Text, etc.) and nothing works. Truly, I have no clue how to fix this and any help whatsoever is much appreciated. Thank you!
Clarification
1) This Excel file is generated from the Web.
2) A Macro turns the Worksheet into a table
3) Left(Range("D362"),1) returns 1 (The number, say, is 12345)
4) Before the error occurs Range("D362") returns (space)12345
5) After the error occurs Range("D362") returns (space)12345
I have just tested this and it works in removing the space at the begining of a string. Sadly it isnt a single line as I (and likely you) would have prefered
Sub test()
Dim CellValue As String
Dim lngNumberOfCharacters As Long
CellValue = ActiveCell.Value
CellValueCheck = Left(CellValue, 1)
If CellValueCheck = " " Then
lngNumberOfCharacters = Len(CellValue) - 1
CellValue = Right(CellValue, lngNumberOfCharacters)
ActiveCell.Value = CellValue
End If
End Sub
Let me know if you need anything confirmed
I want to be able to export a selected range of cells to a .csv file using VBA. What I have come up with so far does the job excellently for cohering selections, but fails misearably when multiple columns are selected.
Here is the code I managed to put together from snippets found on the internet: It also fiddles around with some UI and since my Excel speaks German and I need to have "." as decimal separator instead of "," it tweaks that.
Sub Range_Nach_CSV_()
Dim vntFileName As Variant
Dim lngFN As Long
Dim rngRow As Excel.Range
Dim rngCell As Excel.Range
Dim strDelimiter As String
Dim strText As String
Dim strTextCell As String
Dim strTextCelll As String
Dim bolErsteSpalte As Boolean
Dim rngColumn As Excel.Range
Dim wksQuelle As Excel.Worksheet
Dim continue As Boolean
strDelimiter = vbtab
continue = True
Do While continue = True
vntFileName = Application.GetSaveAsFilename("Test.txt", _
FileFilter:="TXT-File (*.TXT),*.txt")
If vntFileName = False Then
Exit Sub
End If
If Len(Dir(vntFileName)) > 0 Then
Dim ans As Integer
ans = MsgBox("Datei existiert bereits. Überschreiben?", vbYesNo)
If ans = vbYes Then
continue = False
ElseIf ans = vbNo Then
continue = True
Else
continue = False
End If
Else
continue = False
End If
Loop
Set wksQuelle = ActiveSheet
lngFN = FreeFile
Open vntFileName For Output As lngFN
For Each rngRow In Selection.Rows
strText = ""
bolErsteSpalte = True
For Each rngCell In rngRow.Columns
strTextCelll = rngCell.Text
strTextCell = Replace(strTextCelll, ",", ".")
If bolErsteSpalte Then
strText = strTextCell
bolErsteSpalte = False
Else
strText = strText & strDelimiter & strTextCell
End If
Next
Print #lngFN, strText
Next
Close lngFN
End Sub
As I already mentioned the sub works well with coherent selections and also with multiple selected lines, but fails when it comes to multiple columns.
The current output of the sub can be seen on this here picture:
multiple columns failed
As one would expect, I want the .csv-file (or respective .txt-file) to look like this:
multiple columns desired output
How can I achieve the desired behaviour for the last case?
And would someone be so kind to include the links as images? If perceived appropriate, of course.
This might seem a little complex, but your use case isn't very simple...
It does assume that each of the selected areas is the same size, and that they all line up (as either rows or columns)
Sub Tester()
Dim s As String, srow As String, sep As String
Dim a1 As Range, rw As Range, c As Range, rCount As Long
Dim areaCount As Long, x As Long
Dim bColumnsSelected As Boolean
Dim sel As Range
bColumnsSelected = False
Set sel = Selection
areaCount = Selection.Areas.Count
Set a1 = Selection.Areas(1)
If areaCount > 1 Then
If a1.Cells(1).Column <> Selection.Areas(2).Cells(1).Column Then
'areas represent different columns (not different rows)
bColumnsSelected = True
Set sel = a1
End If
End If
rCount = 0
For Each rw In sel.Rows
rCount = rCount + 1
srow = ""
sep = ""
For Each c In rw.Cells
srow = srow & sep & Replace(c.Text, ",", ".")
sep = ","
Next c
'if there are multiple areas selected (as columns), then include those
If bColumnsSelected Then
For x = 2 To areaCount
For Each c In Selection.Areas(x).Rows(rCount).Cells
srow = srow & sep & Replace(c.Text, ",", ".")
Next c
Next x
End If
s = s & IIf(Len(s) > 0, vbCrLf, "") & srow
Next rw
Debug.Print s
End Sub