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
Related
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)
Screenshot#1
So i have to replace positive & negative numbers in column "A", from sheet "1" to sheet second[positive] and third sheet[negative].
Here is what i tried:
Sub Verify()
Dim row As Long
For row = 1 To 20
If ActiveSheet.Cells(row,1) <> "" Then
If ActiveSheet.Cells(row,1) > 0 Then
ActiveSheet.Cells(row,2) = ActiveSheet.Cells(row,1)
End If
End If
Next
End Sub
Here is what that program do:
Screenshot#2
So as we see i am getting positive values in column "B" sheet 1.
Your code is not currently working because you are only using ActiveSheet, rather than placing data on other worksheets as required. Below is some VBA code that loops column A in your original sheet, and outputs the data to column A in two different sheets as required:
Sub sSplitPositiveNegative()
Dim wsOriginal As Worksheet
Dim wsPositive As Worksheet
Dim wsNegative As Worksheet
Dim lngLastRow As Long
Dim lngPositiveRow As Long
Dim lngNegativeRow As Long
Dim lngLoop1 As Long
Set wsOriginal = ThisWorkbook.Worksheets("Original")
Set wsPositive = ThisWorkbook.Worksheets("Positive")
Set wsNegative = ThisWorkbook.Worksheets("Negative")
lngLastRow = wsOriginal.Cells(wsOriginal.Rows.Count, "A").End(xlUp).Row
lngNegativeRow = 2
lngPositiveRow = 2
For lngLoop1 = 1 To lngLastRow
If wsOriginal.Cells(lngLoop1, 1).Value > 0 Then
wsPositive.Cells(lngPositiveRow, 1) = wsOriginal.Cells(lngLoop1, 1)
lngPositiveRow = lngPositiveRow + 1
Else
wsNegative.Cells(lngNegativeRow, 1) = wsOriginal.Cells(lngLoop1, 1)
lngNegativeRow = lngNegativeRow + 1
End If
Next lngLoop1
Set wsPositive = Nothing
Set wsNegative = Nothing
Set wsOriginal = Nothing
End Sub
You will need to change the names of the worksheets referenced in the code to match those in your workbook.
Regards
Made the code a little reusable for you. Feel free to change sheet names or the last_row variable. The last_pos_val and last_neg_val are used so you won't have empty rows on the second and third sheet. You didn't specify what to do with zero, so it's currently added to the negative sheet.
Sub Verify()
Dim row As Long, last_row As Long, last_pos_val As Long, last_neg_val As Long
Dim ws_source As Worksheet, ws_pos As Worksheet, ws_neg As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws_source = wb.Sheets("Sheet1")
Set ws_pos = wb.Sheets("Sheet2")
Set ws_neg = wb.Sheets("Sheet3")
last_pos_val = 1
last_neg_val = 1
last_row = 20
For row = 1 To last_row
If ws_source.Cells(row,1) <> "" Then
If ws_source.Cells(row,1) > 0 Then
ws_pos.Cells(last_pos_val,1) = ws_source.Cells(row,1)
last_pos_val = last_pos_val + 1
Else
ws_neg.Cells(last_neg_val,1) = ws_source.Cells(row,1)
last_neg_val = last_neg_val + 1
End If
End If
Next
End Sub
Split Positive & Negative
Adjust the values in the constants section.
Both subs are needed. The first sub calls the second one.
The Code
Option Explicit
Sub SplitPN()
Const Source As String = "Sheet1"
Const Positive As String = "Sheet2"
Const Negative As String = "Sheet3"
Const FirstRow As Long = 1
Const SourceColumn As Long = 1
Const PositiveFirstCell As String = "A1"
Const NegativeFirstCell As String = "A1"
Dim rngSource As Range
Dim rngPositive As Range
Dim rngNegative As Range
With ThisWorkbook
With .Worksheets(Source)
Set rngSource = .Columns(SourceColumn).Find(What:="*", _
LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rngSource Is Nothing Then Exit Sub
If rngSource.Row < FirstRow Then Exit Sub
Set rngSource = .Range(.Cells(FirstRow, SourceColumn), rngSource)
End With
Set rngPositive = .Worksheets(Positive).Range(PositiveFirstCell)
Set rngNegative = .Worksheets(Negative).Range(NegativeFirstCell)
End With
SplitPosNeg rngSource, rngPositive, rngNegative
End Sub
Sub SplitPosNeg(SourceRange As Range, PositiveFirstCell As Range, _
NegativeFirstCell As Range)
Dim Source, Positive, Negative
Dim UB As Long, i As Long
Source = SourceRange
UB = UBound(Source)
ReDim Positive(1 To UB, 1 To 1)
ReDim Negative(1 To UB, 1 To 1)
For i = 1 To UBound(Source)
Select Case Source(i, 1)
Case Is > 0: Positive(i, 1) = Source(i, 1)
Case Is < 0: Negative(i, 1) = Source(i, 1)
End Select
Next
PositiveFirstCell.Resize(UB) = Positive
NegativeFirstCell.Resize(UB) = Negative
End Sub
I wanted to copy data that fulfil a few criteria from one sheet to another using VBA.
My goal:
Copy Cell in column E, F and G in Sheet FP to column R, S and T in Sheet MUOR if it meets my conditions.
My conditions:
(1) Cell in Column D & Cell in Column P (in Sheet MUOR) must meet the condition in Column I of Sheet FP.
(2) If Cell in Column D is empty, skip to next Cell in Column D.
(3) Column R, S or T must be empty before pasting it. If not empty, move to the next cell that meets the condition. (Do not replace or duplicate the data)
Other information: Max Batch No (Column D) per day is 3;
Issue Facing:
My current VBA code doesn't recognise my conditions. It totally ignored my Day 1 data, and it duplicated all the Day 2 data.
Please refer to the attached images.
Sheet MUOR
Sheet FP
My expected Result
Sample Data here
My current code as below:
Sub LinkData()
Dim y As Long
Dim x As Long
Dim z As Long
Dim lr As Long
Dim arr As Variant
Dim FP As Worksheet
Dim MUOR As Worksheet
Set FP = ThisWorkbook.Sheets("FP")
Set MUOR = ThisWorkbook.Sheets("MUOR")
With FP
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
arr = .Range("A1:I" & lr).Value
End With
With MUOR
For y = 11 To 363
For z = y - 1 To y + 8
For x = LBound(arr) To UBound(arr)
If Cells(11 + y, 4) <> "" And Cells(11 + y, 4) & Cells(10 + z, 16) = arr(x, 9) And IsEmpty(Cells(10 + z, 18)) Then
.Cells(10 + z, 18) = arr(x, 5)
.Cells(10 + z, 19) = arr(x, 8)
.Cells(10 + z, 20) = arr(x, 7)
Else
End If
Next x
Next z
Next y
End With
End Sub
Any VBA expert please help me.
Much appreciated!
I think code below should give expected output, but not totally sure, since the workbook uploaded/shared seems to differ from the screenshots in the question.
Option Explicit
Private Sub LinkData()
Dim arrayFromFPSheet() As Variant
arrayFromFPSheet = GetSourceArray()
Dim MUOR As Worksheet
Set MUOR = ThisWorkbook.Worksheets("MUOR")
Dim rangesToLoopThrough As Range
Set rangesToLoopThrough = GetDestinationAreas(MUOR)
With MUOR
Dim area As Range
For Each area In rangesToLoopThrough.Areas
Debug.Assert area.Rows.CountLarge > 1 And area.Rows.CountLarge < 20
Dim areaFirstRowIndex As Long
areaFirstRowIndex = area.Rows(1).Row
Dim areaLastRowIndex As Long
areaLastRowIndex = area.Rows(area.Rows.Count).Row
Dim readRowIndex As Long
For readRowIndex = areaFirstRowIndex To areaLastRowIndex
If Not IsCellEmpty(.Cells(readRowIndex, "D")) Then
Dim batchNumber As String
batchNumber = CStr(.Cells(readRowIndex, "D"))
Dim writeRowIndex As Long
For writeRowIndex = areaFirstRowIndex To areaLastRowIndex
If IsCellEmpty(.Cells(writeRowIndex, "R")) And IsCellEmpty(.Cells(writeRowIndex, "S")) And IsCellEmpty(.Cells(writeRowIndex, "T")) Then
Dim Grade As String
Grade = CStr(.Cells(writeRowIndex, "P"))
Dim batchNumberAndGrade As String
batchNumberAndGrade = batchNumber & Grade
Dim n As Variant
n = Application.CountIfs(.Range("P" & areaFirstRowIndex, "P" & writeRowIndex), Grade, .Range("R" & areaFirstRowIndex, "R" & writeRowIndex), batchNumber) + 1
Debug.Assert IsNumeric(n)
Dim sourceRowIndex As Long
sourceRowIndex = GetRowIndexOfNthMatch(n, arrayFromFPSheet, batchNumberAndGrade, 9)
If sourceRowIndex > 0 Then
.Cells(writeRowIndex, "R") = arrayFromFPSheet(sourceRowIndex, 5)
.Cells(writeRowIndex, "S") = arrayFromFPSheet(sourceRowIndex, 8)
.Cells(writeRowIndex, "T") = arrayFromFPSheet(sourceRowIndex, 7)
End If
End If
Next writeRowIndex
End If
Next readRowIndex
Next area
End With
End Sub
Private Function GetDestinationAreas(ByVal someSheet As Worksheet) As Range
' Crudely clusters/groups destination sheet into areas (which
' should be date-specific, although this function will not check/verify
' output).
Const START_ROW_INDEX As Long = 10
Dim outputRange As Range
Set outputRange = someSheet.Range("C" & START_ROW_INDEX, "C" & someSheet.Rows.Count)
On Error Resume Next
Set outputRange = outputRange.SpecialCells(xlCellTypeConstants) ' Will raise error if no constants found.
On Error GoTo 0
Debug.Assert Not (outputRange Is Nothing)
Set GetDestinationAreas = outputRange
End Function
Private Function GetSourceArray() As Variant
With ThisWorkbook.Worksheets("FP")
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim outputArray() As Variant
outputArray = .Range("A1:I" & lastRow).Value
End With
GetSourceArray = outputArray
End Function
Private Function IsCellEmpty(ByVal someCell As Range) As Boolean
' https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/isempty-function
' "IsEmpty only returns meaningful information for variants."
' So using below function instead.
IsCellEmpty = Len(CStr(someCell.Value)) = 0
End Function
Private Function GetRowIndexOfNthMatch(ByVal n As Long, ByRef someArray() As Variant, ByVal someText As String, ByVal targetColumn As Long) As Long
' Returns a 1-based row index of the nth occurrence of text value
' in target column of array or 0 if unsuccessful.
Debug.Assert n > 0
Dim rowIndex As Long
For rowIndex = LBound(someArray, 1) To UBound(someArray, 1)
If someArray(rowIndex, targetColumn) = someText Then
Dim matchCount As Long
matchCount = matchCount + 1
If matchCount = n Then
GetRowIndexOfNthMatch = rowIndex
Exit Function
End If
End If
Next rowIndex
End Function
Thanks for all the information you provided in the question. It makes it easier to answer.
Question regarding the code below. I need this randomizer to save the random entries that it created on a separated file without deleting previous entries that got saved, how should I proceed?
Private Sub CommandButton1_Click()
Dim lastRow As Long
Dim shAudit As Worksheet
Dim shData As Worksheet
Dim r As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim key As Variant
name = Range(A5, H9).Value
Set shAudit = ThisWorkbook.Sheets("Sheet1")
Set shData = ThisWorkbook.Sheets("Sheet2")
lastRow = shData.Range("A" & shData.Rows.Count).End(xlUp).Row
'Pick 5 random records with no repeats
Do Until dict.Count = 5
r = Application.WorksheetFunction.RandBetween(2, lastRow)
If Sheets("Sheet1").Range("A2") = Sheets("Sheet2").Cells(r, "G") Then
If Not dict.Exists(r) Then
dict.Add r, r
End If
End If
Loop
r = 0
For Each key In dict.Keys
shData.Range("A1:H1").Offset(key - 1, 0).Copy shAudit.Range("A5:H5").Offset(r, 0)
r = r + 1
Next key
End Sub
You can add this line just before End Sub. Change the sheet name to suit.
Worksheets("Sheet3").Range("A" & Rows.Count).End(xlUp)(2).Resize(dict.Count) = Application.Transpose(dict.keys)
Using the code below I have been able to obtain the indented BOM for any parent item (specified in cell D1). Screen shot below shows the indented bom in columns D, E & F obtained for item A based of the Parent / Child relationships listed in columns A and B. I would like to expand this slightly so that the associated qty of each child item is shown in column G. I was trying to obtain the address corresponding to vChild and then offset by 1 column but I have had no success.
Any ideas appreciated
Public collRoot As Collection
Sub DisplayTree()
Dim coll As Collection
Dim rParents As Range, rNode As Range
Dim rOut As Range, sRootNode As String, lRow As Long
Dim rLevels As Range, rLevel As Range
Dim level As Integer, maxLevels As Integer, cur As Integer, i As Integer
Dim h As String, counts() As Integer
Set collRoot = Nothing
Set collRoot = New Collection
Set rParents = Range("A2", Range("A2").End(xlDown))
' Store the tree in a collection
On Error Resume Next
For Each rNode In rParents
Set coll = Nothing
Set coll = collRoot(rNode.Value)
If coll Is Nothing Then collRoot.Add New Collection, rNode.Value
collRoot(rNode.Value).Add rNode.Offset(, 1).Value
Next rNode
sRootNode = Range("D1")
Range("D2") = 0
Range("F2") = sRootNode
Set rOut = Range("D2")
Call DisplayTree1(sRootNode, rOut, lRow, 1)
' Calculate Levels
Set rLevels = Range("D3:D" & Range("D3").End(xlDown).Row)
maxLevels = WorksheetFunction.Max(rLevels)
ReDim counts(1 To maxLevels)
cur = 1
For Each rLevel In rLevels
level = rLevel.Value
h = ""
counts(level) = counts(level) + 1
For i = 1 To level
h = h & "." & counts(i)
Next
h = Mid(h, 2)
For i = level + 1 To UBound(counts)
counts(i) = 0
Next
rLevel.Offset(, 1).Value = h
cur = level
Next
End Sub
Sub DisplayTree1(ByVal sParent As String, rOut As Range, _
ByRef lRow As Long, ByVal lLevel As Long)
Dim vChild, coll As Collection
On Error Resume Next
For Each vChild In collRoot(sParent)
lRow = lRow + 1
rOut.Offset(lRow, 2) = vChild
rOut.Offset(lRow, 0) = lLevel
Set coll = Nothing
Set coll = collRoot(vChild)
If Not coll Is Nothing Then Call DisplayTree1(vChild, rOut, lRow, lLevel + 1)
Next vChild
End Sub
I have elected to use a workaround using vlookups to obtain the qty values