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)
Related
I need a dynamic way to add Note in which cell in my ID column A. However the comments need to use the information from Column B and C. ex: ON 01/13/2020, Anne.
I am not sure how to check how many times each value from column A will appear and use information from column D and B to create the comment (NOTE)..
result I need. All the time the ID number will be the same the comments need to be the same as well.
The code I am using is
Sub Cmt_test()
Sheet1.Range("A2").AddComment "On " & Sheet1.Range("D2") & ", " & Sheet1.Range("B2")
End Sub
I don't know how I can make it dynamic to get the information all the time the same ID appears. Maybe if I use Loop on column A would it be possible that all the time the loop finds the same ID to add the comment using the information from column D and B?
Write Comments to Each Cell in a Column
Option Explicit
Sub addComments()
Const wsName As String = "Sheet1"
Const FirstRow As Long = 2
Const LastRowCol As Long = 1 ' or "A"
Const str1 As String = "On "
Const str2 As String = ", "
Dim Cols As Variant: Cols = Array(1, 2, 4)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow: LastRow = ws.Cells(ws.Rows.Count, LastRowCol).End(xlUp).Row
Dim Vals As Variant: ReDim Vals(UBound(Cols))
' Define Source Range.
Dim rng As Range: Set rng = ws.Range(ws.Cells(FirstRow, Cols(0)), _
ws.Cells(LastRow, Cols(0)))
' Write Column Ranges to Arrays.
Dim j As Long
For j = 0 To UBound(Cols)
Vals(j) = rng.Offset(, Cols(j) - Cols(0))
Next j
' Loop through elements (rows) of Source Array
' and write comments to a dictionary.
Dim dict As Object, Curr As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Vals(0))
Curr = Vals(0)(i, 1)
If dict(Curr) <> "" Then
dict(Curr) = dict(Curr) & vbLf & str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
Else
dict(Curr) = str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
End If
Next i
' Write comments from the dictionary to Source Range.
rng.ClearComments
Dim cel As Range
For Each cel In rng.Cells
cel.AddComment dict(cel.Value)
Next cel
End Sub
I'm trying to create a vba script that will search for the _ in all the cells fallen under Crude Items column. However, when it finds one, it will split the values from _ and place the rest in corresponding cells fallen under Refined Ones column.
I've tried with the following which is doing the job flawlessly but I wish to search and replace the values using column headers:
Sub CopyAndReplace()
Dim cel As Range
For Each cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).row)
If cel.value <> "" Then
Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
End If
Next cel
End Sub
To let you visualize how the sheet might look like:
How can I search and replace the values using column headers?
I am not sure this is what you are after, but a few important mentions...
Try to always use at least a worksheet qualifier when writing your code. How else is your program going to know explicitly where you would like it to operate?
I have changed your process slightly, but again, not sure if this is exactly what you are after. See below code.
Sub SplitByHeader()
Dim i As Long
Dim crudeHeader As Range, refinedHeader As Range
Dim ws As Worksheet
'set ws
Set ws = ThisWorkbook.Sheets("Sheet1")
'set header ranges
Set crudeHeader = ws.Rows(1).Find(What:="Crude Items", LookAt:=xlWhole)
Set refinedHeader = ws.Rows(1).Find(What:="Refined Ones", LookAt:=xlWhole)
'simple error handler
If crudeHeader Is Nothing Or refinedHeader Is Nothing Then Exit Sub
For i = 2 To ws.Cells(ws.Rows.Count, crudeHeader.Column).End(xlUp).Row
If ws.Cells(i, crudeHeader.Column).Value <> "" Then
ws.Cells(i, refinedHeader.Column).Value = Split(ws.Cells(i, crudeHeader.Column).Value, "_")(1)
End If
Next i
End Sub
I have just tried this one with the code below:
It is a good idea to add additional check to the condition, like this - If myCell.Value <> "" And InStr(1, myCell, "_") Then to avoid starting from A2.
The idea is that the LocateValueCol locates the column of the first row, which has the string, passed to it. Knowing this, it works ok.
Option Explicit
Sub CopyAndReplace()
Dim searchColumn As Long
searchColumn = LocateValueCol("SearchCol", Worksheets(1))
Dim replaceColumn As Long
replaceColumn = LocateValueCol("ReplaceCol", Worksheets(1))
Dim myCell As Range
Dim lastCell As Long
With Worksheets(1)
lastCell = .Cells(.Rows.Count, searchColumn).End(xlUp).Row
For Each myCell In .Range(.Cells(1, searchColumn), .Cells(lastCell, searchColumn))
If myCell.Value <> "" And InStr(1, myCell, "_") Then
.Cells(myCell.Row, replaceColumn) = Split(myCell, "_")(1)
End If
Next
End With
End Sub
This is the function, locating the columns. (If you have ideas for improvement, feel free to make a PR here):
Public Function LocateValueCol(ByVal textTarget As String, _
ByRef wksTarget As Worksheet, _
Optional rowNeeded As Long = 1, _
Optional moreValuesFound As Long = 1, _
Optional lookForPart = False, _
Optional lookUpToBottom = True) As Long
Dim valuesFound As Long
Dim localRange As Range
Dim myCell As Range
LocateValueCol = -999
valuesFound = moreValuesFound
Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.Count))
For Each myCell In localRange
If lookForPart Then
If textTarget = Left(myCell, Len(textTarget)) Then
If valuesFound = 1 Then
LocateValueCol = myCell.Column
If lookUpToBottom Then Exit Function
Else
Decrement valuesFound
End If
End If
Else
If textTarget = Trim(myCell) Then
If valuesFound = 1 Then
LocateValueCol = myCell.Column
If lookUpToBottom Then Exit Function
Else
Decrement valuesFound
End If
End If
End If
Next myCell
End Function
Private Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1)
valueToIncrement = valueToIncrement + incrementWith
End Sub
Private Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1)
valueToDecrement = valueToDecrement - decrementWith
End Sub
For fun using regex and dynamically finding header columns. You can swop out the regex based function for your own and still have the dynamic column finding.
Option Explicit
Public Sub test()
Dim i As Long, inputs(), re As Object, ws As Worksheet
Dim inputColumn As Range, outputColumn As Range, inputColumnNumber As Long, outputColumnNumber As Long
Const SEARCH_ROW As Long = 1
Const INPUT_HEADER As String = "Crude items"
Const OUTPUT_HEADER As String = "Refined Ones"
Const START_ROW = 2
Set re = CreateObject("VBScript.RegExp")
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set inputColumn = GetColumnByHeader(ws, SEARCH_ROW, INPUT_HEADER)
Set outputColumn = GetColumnByHeader(ws, SEARCH_ROW, OUTPUT_HEADER)
If inputColumn Is Nothing Or outputColumn Is Nothing Then Exit Sub
inputColumnNumber = inputColumn.Column
outputColumnNumber = outputColumn.Column
With ws
inputs = Application.Transpose(.Range(.Cells(START_ROW, inputColumnNumber), .Cells(.Cells(.Rows.Count, inputColumnNumber).End(xlUp).Row, inputColumnNumber)).Value)
For i = LBound(inputs) To UBound(inputs)
inputs(i) = GetMatch(re, inputs(i))
Next
.Cells(START_ROW, outputColumnNumber).Resize(UBound(inputs), 1) = Application.Transpose(inputs)
End With
End Sub
Public Function GetColumnByHeader(ByVal ws As Worksheet, ByVal SEARCH_ROW As Long, ByVal columnName As String) As Range
Set GetColumnByHeader = ws.Rows(SEARCH_ROW).Find(columnName)
End Function
Public Function GetMatch(ByVal re As Object, ByVal inputString As String) As String
With re
.Global = True
.MultiLine = True
.Pattern = "_(.*)"
If .test(inputString) Then
GetMatch = .Execute(inputString)(0).SubMatches(0)
Else
GetMatch = inputString 'or =vbNullString if want to return nothing
End If
End With
End Function
If you are working through an actual table things will become quite easy:
Sub Test()
Dim arr(), x As Long
With ThisWorkbook.Sheets("Sheet1") 'Change accordingly
For Each cl In .Range("Table1[Crude Items]") 'Change Table1 accordingly
ReDim Preserve arr(x)
If InStr(cl, "_") > 0 Then
arr(x) = Split(cl, "_")(1)
Else
arr(x) = ""
End If
x = x + 1
Next cl
.Range("Table1[Refined Ones]").Value = Application.Transpose(arr)
End With
End Sub
There is a check for "_". If not there, the cell will be kept empty.
You can also consider to use formula to do it.
I am not clear about what you want to replace "_" character with. For example, iff you replace the following line of your script:
Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
with this one:
Sheets("Sheet1").Range(cel(1, 3).Address) = WorksheetFunction.Substitute(cel, "_", "")
The above line should replace the "_" character with nothing from the cells in the Crude_Items column
And as Lee said, you can also consider using formula in the worksheet if you do not have significant amount of data
I am trying to filter data on 3 different sheets using this code, but the filterBy sub runs dramatically slower on the second and third sheet when I use expressPrepper to do it all in one click.
I'm guessing the second and third filter by run approximately 1/200 the speed of the first one. I can't figure out why.
All three sheets contain similar data, although the third is actually shorter (~6500 rows) than the first two (~16000 rows each).
Any help would be greatly appreciated!
Sub filterBy(filterlist As String, col As String, sht As String)
Dim myArr As Variant
myArr = buildArray(filterlist)
clean myArr, col, sht
End Sub
Function buildArray(filterlist As String) As Variant
Dim myTable As ListObject
Dim TempArray As Variant
Select Case filterlist
Case Is = "I"
Set myTable = Sheets("Competitive Set").ListObjects("Table1")
TempArray = myTable.DataBodyRange.Columns(1)
buildArray = Application.Transpose(TempArray)
Case Is = "T"
Set myTable = Sheets("Competitive Set").ListObjects("Table1")
TempArray = myTable.DataBodyRange.Columns(2)
buildArray = Application.Transpose(TempArray)
Case Is = "IB"
Set myTable = Sheets("Competitive Set").ListObjects("Table2")
TempArray = myTable.DataBodyRange.Columns(1)
buildArray = Application.Transpose(TempArray)
Case Is = "TB"
Set myTable = Sheets("Competitive Set").ListObjects("Table2")
TempArray = myTable.DataBodyRange.Columns(2)
buildArray = Application.Transpose(TempArray)
Case Is = "AB"
Set myTable = Sheets("Competitive Set").ListObjects("Table3")
TempArray = myTable.DataBodyRange.Columns(1)
buildArray = Application.Transpose(TempArray)
End Select
End Function
Sub clean(arr As Variant, col As String, sht As String)
Dim IsInArray As Long
Dim product As String
Dim lastRow As Long, i As Long
Dim progress As Double
With Sheets(sht)
lastRow = .Cells(Rows.Count, col).End(xlUp).Row
For i = lastRow To 2 Step -1
product = .Cells(i, col).Value
IsInArray = UBound(filter(arr, product))
If IsInArray < 0 Then
.Rows(i).EntireRow.Delete
End If
progress = ((lastRow - i) / lastRow) * 100
progress = Round(progress, 2)
Debug.Print progress
Next i
End With
End Sub
Sub expressPrepper()
filterBy "AB", "C", "Spend"
filterBy "AB", "C", "IMP"
filterBy "AB", "C", "GRP"
End Sub
If I understand your program correctly there should be no need for filtering and, hence, no problem from applying thousands of filters. I have re-written your program - the way I understood it - without such need, basically, deleting rows which don't have a duplicate in the designated column. The code is untested.
Sub ExpressFilter()
Dim Flt() As String, i As Integer
Dim Sp() As String, j As Integer
Dim TblName As String
Dim ClmRng As Range
Flt = Split("AB,C,Spend|AB,C,IMP|AB,C,GRP", "|")
For i = 0 To UBound(Flt)
Sp = Split(Flt(i), ",")
Select Case Sp(0)
Case Is = "I"
TblName = "Table1"
C = 1
Case Is = "T"
TblName = "Table1"
C = 2
Case Is = "IB"
TblName = "Table2"
C = 1
Case Is = "TB"
TblName = "Table2"
C = 2
Case Is = "AB"
TblName = "Table3"
C = 1
End Select
Set ClmRng = Worksheets("Competitive Set").ListObjects(TblName).DataBodyRange.Columns(C)
DeleteSingles ClmRng, Columns(Sp(1)).Column, Sp(2)
Next i
End Sub
Private Sub DeleteSingles(ClmRng As Range, _
C As Long, _
Sht As String)
Dim Fnd As Range
Dim IsInArray As Long
Dim lastRow As Long, R As Long
With Sheets(Sht)
lastRow = .Cells(Rows.Count, C).End(xlUp).Row
For R = lastRow To 2 Step -1
With ClmRng
Set Fnd = .Find(What:=.Cells(R, C).Value, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
MatchCase:=False)
End With
If Fnd Is Nothing Then .Rows(R).EntireRow.Delete
If (R Mod 25 = 0) or (R = 2) Then
Application.StatusBar = Round(((lastRow - R) / lastRow) * 100, 0) & "% done"
End If
Next R
End With
End Sub
Note that the progress is shown in the Status Bar at the left bottom of the screen.
As you can see that the value in column Amount in the first image is manually put into it. I would like to use VBA to do it automatically.
Table B546789 is one of the worker:
PriceList shown the amount of each code item:
Code:
Sub FINDSAL()
Dim E_name() As String
Dim Sal As String
Dim sheet As Worksheet
Set sheet = ActiveWorkbook.Sheets("PriceList")
SourceString = Worksheets("B546789").Range("B2").Value
E_name() = Split(SourceString, ",")
Sal = Application.WorksheetFunction.VLookup(E_name, Worksheets("PriceList").Range("A2:B7"), 2, False)
End Sub
A simple SUMPRODUCT should do this.
=SUMPRODUCT(--ISNUMBER(FIND(F$2:F$8, B2)), G$2:G$8)
VBA code:
Dim a As Long, b As Long, ttl As Double
Dim vals As Variant, pc As Variant
Dim sh As Worksheet
Set sh = ActiveWorkbook.Sheets("PriceList")
With Worksheets("B546789")
For b = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
ttl = 0
vals = Split(.Cells(b, "B").Value2, Chr(44))
For a = LBound(vals) To UBound(vals)
pc = Application.Match(vals(a), sh.Columns(1), 0)
If Not IsError(pc) Then
ttl = ttl + sh.Cells(pc, "B").Value2
End If
Next a
.Cells(b, "C") = ttl
Next b
End With
Any hints that when i put below code to VBA ThisWorkbook, work fine. But assign this Marco to a button, it will crash when i run. do you know why?
Sub test()
Dim a As Long, b As Long, ttl As Double, ttlerror As String
Dim vals As Variant, pc As Variant
Dim sh As Worksheet
Dim WshtNames As Variant
Dim WshtNameCrnt As Variant
Set sh = ActiveWorkbook.Sheets("PriceList")
WshtNames = Array("B54546", "B87987")
For Each WshtNameCrnt In WshtNames
With Worksheets(WshtNameCrnt)
For b = 8 To [D8].End(xlDown).Row
ttl = 0
ttlerror = ""
vals = Split(.Cells(b, "D").Value2, Chr(44))
For a = LBound(vals) To UBound(vals)
pc = Application.Match(vals(a), sh.Columns(1), 0)
If Not IsError(pc) Then
ttl = ttl + sh.Cells(pc, "B").Value2
End If
Next a
.Cells(b, "E") = ttl
.Cells(b, "F") = ttlerror
Next b
End With
Next WshtNameCrnt
End Sub
the issue maybe related to this "For b = 8 To [D8].End(xlDown).Row", it only happen when i use the button feature.
Image here
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