Related
Is there someone can help me? I have here code that can duplicate entire row to have 2 rows. After duplicating the first entire row , I want to load string from range "G" into array so that I can get certain string that Am planning to insert in "Thickness" and "width" column for me to use to calculate the "Weight" of the "Profile Type". If you will see I have an array in the code .But that array work differently for me and I had a hard time fulfilling the requirements I need. The array in my code split the String using "X" as delimiter . Once the string was split it will add another cells for each split string. what I want is to do the split not in the column but in the array only so that I can maintain the data in G . I will use the string assigned in the array to get "Thickness and Width" of the profile which is "15 as Thickness and 150 as width". If there's any way to do same thing using other code it will be more helpful to simplify the code.
Reminder that Profiletype string vary its length . Sometimes profile width are 4 digits (LB1000X4500X12/15)
Below are the snapshot of my worksheet for you to identify what the result will be.
Private Sub CommandButton2_Click()
Dim lastrow As Long
Dim i As Integer
Dim icount As Integer
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
'array
'Columns("G:G").NumberFormat = "#"
Dim c As Long, r As Range, v As Variant, d As Variant
For i = 2 To Range("G" & Rows.Count).End(xlUp).Row '2 to 16 cell
'v = Split (range("G" & i), "X")
v = Split((Cells(x, "G") & i), "x")
c = c + UBound(v) + 1
'Next i
For i = 2 To c
If Range("G" & i) <> "" Then
Set r = Range("G" & i)
Dim arr As Variant
arr = Split(r, "X")
Dim j As Long
r = arr(0)
For j = 1 To UBound(arr)
Rows(r.Row + j & ":" & r.Row + j).Insert Shift:=xlDown
r.Offset(j, 0) = arr(j)
r.Offset(j, -1) = r.Offset(0, -1)
r.Offset(j, -2) = r.Offset(0, -2)
Next j
End If
Next i
End If
Next x
End Sub
Does this do what you want? Run in copy of workbook to be safe.
Option explicit
Private Sub CommandButton2_Click()
'Bit redundant, would be better if you fully qualify workbook and worksheet with actual names.'
Dim TargetWorksheet as worksheet
Set TargetWorksheet = Activesheet
With application
.screenupdating = false
.calculation = xlcalculationmanual
End with
With TargetWorksheet
.range("G:G").numberformat = "#"
Dim RowIndex As Long
For RowIndex = .usedrange.rows.countlarge to 1 step -1
If .Cells(RowIndex, "F").value2 = "LB" Then
.Cells(RowIndex, "F").value2 = "ComP"
.Cells(RowIndex + 1, "F").EntireRow.Insert
.Cells(RowIndex, "F").EntireRow.Copy .Cells(RowIndex + 1, "F").EntireRow
Dim SplitProfileType() as string
SplitProfileType = split(mid(.cells(RowIndex+1,"G").value2,3), "X") ' assumes first two characters will always be LB, that it is safe to ignore them and start from third character.'
' Write thickness'
.cells(RowIndex+1, "H").value2 = cdbl(mid(SplitProfileType(ubound(SplitProfileType)),instrrev(SplitProfileType(ubound(SplitProfileType)),"/",-1,vbbinarycompare)+1)
' Write width'
.cells(RowIndex+1, "i").value2 = cdbl(SplitProfileType(1))
' Calculate weight'
.cells(RowIndex+1,"K").value2 = .cells(RowIndex+1,"H").value2 * .cells(RowIndex+1,"I").value2 * .cells(RowIndex+1,"J").value2
End if
' I think because you are inserting a row below (rather than above/before), your RowIndex remains unaffected and no adjustment is needed to code. I could be wrong. I would need to test it to be sure.'
Next rowindex
End with
With application
.screenupdating = true
.calculation = xlcalculationautomatic
End with
End sub
Untested as written on mobile.
It works without duplication.
Sub test2()
Dim vDB, vR()
Dim i As Long, n As Long, k As Long, j As Integer
Dim r As Integer
Dim s As String
vDB = Range("A2", "K" & Range("A" & Rows.Count).End(xlUp).Row)
n = UBound(vDB, 1)
For i = 1 To n
If vDB(i, 6) = "LB" Then
r = 2
Else
r = 1
End If
k = k + r
ReDim Preserve vR(1 To 11, 1 To k)
s = vDB(i, 7)
For j = 1 To 11
If r = 1 Then
vR(j, k) = vDB(i, j)
Else
vR(j, k - 1) = vDB(i, j)
vR(j, k) = vDB(i, j)
End If
Next j
If r = 2 Then
vR(6, k - 1) = "comp"
vR(6, k) = "comp"
vR(8, k) = Split(s, "/")(1)
vR(9, k) = Split(s, "X")(1)
vR(9, k - 1) = vR(9, k - 1) - vR(8, k)
vR(11, k - 1) = (vR(8, k - 1) * vR(9, k - 1) * vR(10, k - 1) * 7.85) / 10 ^ 6 '<~~ k2 weight
vR(11, k) = (vR(8, k) * vR(9, k) * vR(10, k) * 7.85) / 10 ^ 6 '<~~ k3 weight
End If
Next i
Range("f1") = "Type"
Range("a2").Resize(k, 11) = WorksheetFunction.Transpose(vR)
End Sub
It is faster to use an array than to enter it one-to-one in a cell.
Sub test()
Dim vDB, vR()
Dim i As Long, n As Long, k As Long, j As Integer
Dim s As String
vDB = Range("A2", "K" & Range("A" & Rows.Count).End(xlUp).Row)
n = UBound(vDB, 1)
ReDim vR(1 To n * 2, 1 To 11)
For i = 1 To n
k = k + 2
s = vDB(i, 7)
For j = 1 To 11
vR(k - 1, j) = vDB(i, j)
vR(k, j) = vDB(i, j)
Next j
vR(k - 1, 6) = "comp"
vR(k, 6) = "comp"
vR(k, 8) = Split(s, "/")(1)
vR(k, 9) = Split(s, "X")(1)
vR(k, 11) = Empty '<~~ This is calculated Weight value place
Next i
Range("f1") = "Type"
Range("a2").Resize(n * 2, 11) = vR
End Sub
Good day to all,
I keep getting the same runtime error while executing my code. I don't have formal training in VBA (mostly some VB in highschool).
The code is this
Sub Lavaggi2():
Dim i, j, k, lavaggio, x, daymax As Integer
Dim day As Date
Dim Ore(10) As Single
Dim column_len, row_len As Integer
Dim totale_ore As Integer
'Determining variable for row and columns
column_len = Sheets("Foglio7").Cells.CurrentRegion.Columns.Count
row_len = Sheets("Foglio7").Cells.CurrentRegion.Rows.Count
k = 1
For j = 1 To row_len
For i = 1 To column_len
If (Sheets("Foglio7").Cells(2, i).Value = "Codice") Then
If (Sheets("Foglio7").Cells(j, i).Value = "00/100" Or Sheets("Foglio7").Cells(j, i).Value = "00/200") Then
day = Sheets("Foglio7").Cells(j, 1).Value
For k = 1 To 10
If (Sheets("Foglio7").Cells(j - k, 1).Value = day) Then
Ore(k) = Sheets("Foglio7").Cells(j - k, i + 5).Value
daymax = daymax + 1
Else
End If
Next k
totale_ore = Worksheet.funcion.Sum(Ore)
lavaggio = Sheets("Foglio7").Cells(j, i + 7) / totale_ore
For x = 1 To daymax
Sheets("Foglio7").Cells(j - x, i + 7).Value = lavaggio * Ore(x)
Next x
Erase Ore
End If
End If
Next i
Next j
End Sub
The line where I get the error is
If (Sheets("Foglio7").Cells(j - k, 1).Value = day) Then
I'm quite sure it's something silly but I'm unable to wrap my head around it.
PS: I'm aware that the code is probably a little clunky but I'll streamline it at a future stage.
Thanks to all who will answer
On your first iteration of the loop, j - k would equal 0, and your cell would be .Cells(0, 1), which doesn't exist.
I managed to solve the issues I encountered. It works as intended. Thanks to all for the help
Sub Lavaggi2():
Dim i, j, k, x, daymax As Integer
Dim day As Date
Dim lavaggio, totale_ore, Ore(10) As Double
Dim column_len, row_len As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
column_len = Sheets("Foglio7").Cells.CurrentRegion.Columns.Count
row_len = Sheets("Foglio7").Cells.CurrentRegion.Rows.Count
daymax = 1
For j = 1 To row_len
For i = 1 To column_len
If (Sheets("Foglio7").Cells(2, i).Value = "Codice") Then
If (Sheets("Foglio7").Cells(j, i).Value = "00/100" Or Sheets("Foglio7").Cells(j, i).Value = "00/200") Then
day = Sheets("Foglio7").Cells(j, 1).Value
For k = 1 To 10
If (Sheets("Foglio7").Cells(j - k, 1).Value = day) Then
Ore(k) = Sheets("Foglio7").Cells(j - k, i + 5).Value
daymax = daymax + 1
Else
Exit For
End If
Next k
totale_ore = Application.WorksheetFunction.Sum(Ore)
lavaggio = Sheets("Foglio7").Cells(j, i + 7) / totale_ore
For x = 1 To daymax - 1
Sheets("Foglio7").Cells(j - x, i + 7).Value = lavaggio * Ore(x)
Next x
daymax = 1
Erase Ore
End If
End If
Next i
Next j
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I also tweaked the declarations in order to achieve the desired precision in the final results.
I have a bunch of subs for different categories in a table I'm building in excel. Each sub has its' own data it pulls from various flat files, but it all has the same ending which is placing each value into a specific cell based on the category header it aligns to in the row and column. So, all that is different is the if statement at the beginning. Is there a way to put this block of code in a separate sub or function or something and have just one call to it in each other sub so that I don't have to constantly type it out/ if I want to change it I would only have to change it in one place? Here is an example of the code:
This part is at the beginning of each sub and changes based on the row header
Sub calccategory()
For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
If Cells(k, 4) = "row 1" Then
This part is the part I want to place in a function or sub because it will be the same every time
Dim CWS As Worksheet
Workbooks(ThisBook).Activate
For j = 5 To 15
For g = 1 To ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column
If Cells(3, g) = "col1" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col1_n
End With
ElseIf Cells(3, g) = "col2" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col2_n
End With
ElseIf Cells(3, g) = "col3" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col3_n
End With
ElseIf Cells(3, g) = "col 4" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col4_n
End With
ElseIf Cells(3, g) = "col5" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col5_n
End With
End If
Next g
On Error GoTo 0
Next j
This part would again me part of the end of each sub and not a part of this function I want
End If
Next k
End Sub
What you need to do, as I posted in a comment, is pass the arguments to the new sub. Also, you have lots of recurring code, so I tried to tighten that up.
Sub calccategory()
For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
If Cells(k, 4) = "row 1" Then
theLoop k
End If
Next k
End Sub
Sub theLoop(ByVal k As Integer)
Dim CWS As Worksheet
Set CWS = Workbooks(ThisBook)
For j = 5 To 15
With CWS
For g = 1 To .Cells(3, .Columns.Count).End(xlToLeft).Column
With .Range(.Cells(k, j * 4 + 2), .Cells(k + 1, j * 4 + 4))
On Error Resume Next
If .Cells(3, g) = "col1" Then .Cells(k, g).Value = col1_n
ElseIf .Cells(3, g) = "col2" Then .Cells(k, g).Value = col2_n
ElseIf .Cells(3, g) = "col3" Then .Cells(k, g).Value = col3_n
ElseIf .Cells(3, g) = "col 4" Then .Cells(k, g).Value = col4_n
ElseIf .Cells(3, g) = "col5" Then .Cells(k, g).Value = col5_n
End If
End With
Next g
End With 'CWS
On Error GoTo 0
Next j
End Sub
Well, you should do something like this...
Option Explicit
Public Sub CalCategoryInternal(ByVal str_col2 As String, _
ByVal g As Long, _
ByVal k As Long, _
ByVal j As Long, _
ByRef CWS As Worksheet)
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = str_col2
On Error GoTo 0
End With
End Sub
Sub calccategory()
Dim k, ThisBook, j, g, col1_n, col2_n, col3_n, col4_n, col5_n
For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
If Cells(k, 4) = "row 1" Then
Dim CWS As Worksheet
Workbooks(ThisBook).Activate
For j = 5 To 15
For g = 1 To ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column
If Cells(3, g) = "col1" Then
Call CalCategoryInternal("col1", g, k, j, CWS)
' With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
' On Error Resume Next
' CWS.Cells(k, g).Value = col1_n
' End With
ElseIf Cells(3, g) = "col2" Then
Call CalCategoryInternal("col1", g, k, j, CWS)
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col2_n
End With
ElseIf Cells(3, g) = "col3" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col3_n
End With
ElseIf Cells(3, g) = "col 4" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col4_n
End With
ElseIf Cells(3, g) = "col5" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col5_n
End With
End If
Next g
On Error GoTo 0
Next j
End If
Next k
End Sub
Beware - this is really a low quality code. E.g. the "Dim"s on the top should not be declared this way and you can improve it further a lot. I do not see where you set the worksheet, thus I suppose that this is just a small part of the code. Enjoy it!
yeah you can easily stick that in its own sub, and you can pass K into it as an argument by value, that would just look like this:
Sub calccategory()
For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
If Cells(k, 4) = row 1" Then
Call newSub(k)
End If
Next k
End Sub
Sub newSub(byval k as long)
Dim CWS As Worksheet
Workbooks(ThisBook).Activate
For j = 5 To 15
For g = 1 To ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column
If Cells(3, g) = "col1" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col1_n
End With
ElseIf Cells(3, g) = "col2" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col2_n
End With
ElseIf Cells(3, g) = "col3" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col3_n
End With
ElseIf Cells(3, g) = "col 4" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col4_n
End With
ElseIf Cells(3, g) = "col5" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))
On Error Resume Next
CWS.Cells(k, g).Value = col5_n
End With
End If
Next g
On Error GoTo 0
Next j
end sub
you might also consider using a select statement and nesting your select statement in your with range.. although it doesn't look like you're actually referencing your with statement so you can probably get rid of it.
I'd wonder where you're getting variables "ThisBook" "col1_n" / "col2_n" ... cause you might run into a "function or variable not defined" issue unless you define them either module wide or pass them in as arguments into the function.
You're also not defining CWS equal to anything so you might get an object required error. which is what I assume the on error resume next statements are about.
So some of the improvements might look similar to this:
Sub calccategory()
For k = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
If Cells(k, 4) = "row 1" Then
Call newSub(k)
End If
Next k
End Sub
Sub newSub(ByVal k As Long)
Dim CWS As Worksheet
Set CWS = Workbooks(ThisBook).Sheets("mySheetName")
For j = 5 To 15
On Error Resume Next
For g = 1 To ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column
If Cells(3, g) = "col1" Then
With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) 'still unused
CWS.Cells(k, g).Value = col1_n
Select Case Cells(3, g)
Case "col2"
CWS.Cells(k, g).Value = col2_n
Case "col3"
CWS.Cells(k, g).Value = col3_n
Case "col 4"
CWS.Cells(k, g).Value = col4_n
Case "col5"
CWS.Cells(k, g).Value = col5_n
End Select
End With
End If
Next g
On Error GoTo 0
Next j
End Sub
Good luck!
meanwhile you're adding more info, I can throw in what follows:
Option Explicit
Sub calccategory()
Dim k As Long
Dim CWS As Worksheet
Dim col1_n As Variant, col2_n As Variant, col3_n As Variant, col4_n As Variant, col5_n As Variant
With ActiveSheet
For k = 1 To .Cells(Rows.Count, 4).End(xlUp).Row
If .Cells(k, 4) = "row 1" Then FillValues k, Workbooks("ThisBook").ActiveSheet, CWS, Array(col1_n, col2_n, col3_n, col4_n, col5_n)
Next k
End With
End Sub
Sub FillValues(k As Long, ws As Worksheet, CWS As Worksheet, colArray As Variant)
Dim j As Long, G As Long, col As Long
Dim strng As String
With ws
' For j = 5 To 15 '<--| I commented it since it seems not to be used anywhere, once removing that 'With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4))'
For G = 1 To .Cells(3, .Columns.Count).End(xlToLeft).Column
strng = .Cells(3, G).Value2
If Left(strng, 3) = "col" Then
If IsNumeric(Mid(strng, 4, 1)) Then
col = CLng(Mid(strng, 4, 1))
If col <= 5 Then CWS.Cells(k, G).Value = colArray(col - 1)
End If
End If
Next G
' Next j
End With
End Sub
but there's plenty of thing you should explain (ThisBook, CWS, With Range(Cells(k, j * 4 + 2), Cells(k + 1, j * 4 + 4)) )to make a sense of it!
I am trying to develop develop a model to calculate the sum of a cone to row 1 given an array of variable size only if the value of the cell is > 0.
If the sum is then >=1 I wish to color the range of the cone to display this. If the cone hits the A row boundary I need it not to error and for it to extend in the cone shape the other boundary. Here is what I have at the moment:
Public Sub MC()
Worksheets("SC").Cells.Clear
Dim i&, j&
For j = 1 To Worksheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
If Worksheets("Data").Cells(i, j) > 0 Then
Worksheets("SC").Cells(i, j).Address , SumAndColorCone(Cells(i, j))
Else: If Worksheets("Data").Cells(i, j) <= 0 Then Worksheets("SC").Cells(i, j) = "0"
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
If r.Column - k < 2 Then Exit For
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
Try this:
Public Sub MC()
Dim c&, i&, j&
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Val(Cells(i, j)) > 0 Then
c = RGB(Int(Rnd * 255) + 1, Int(Rnd * 255) + 1, Int(Rnd * 255) + 1)
Debug.Print "Testing value at: " & Cells(i, j).Address & vbLf & "Cone sum: " & SumAndColorCone(Cells(i, j), c) & vbLf
End If
Next
Next
End Sub
Private Function SumAndColorCone(r As Range, color&) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
If r.Column - k < 2 Then
Set c = Union(c, r(-k, -r.Column + 2).Resize(, r.Column + k + 1))
Else
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
End If
k = k + 1
Next
SumAndColorCone = Application.Sum(c)
If SumAndColorCone > 1 Then c.Interior.color = color
End Function
I am trying to write a general code for matrix multiplication but when I am trying to verify it, the output is always a null matrix. So it seems that the values of the temp matrix are not getting updated.
Please suggest some changes for it to work. The code is copied below:
Public Function matrixmultiply(x() As Double, y() As Double) As Double()
Dim nrow1 As Integer, nrow2 As Integer, ncol1 As Integer, ncol2 As Integer, i As Integer, j As Integer, k As Integer, temp() As Double
nrow1 = UBound(x, 1) - LBound(x, 1) + 1
ncol1 = UBound(x, 2) - LBound(x, 2) + 1
nrow2 = UBound(y, 1) - LBound(y, 1) + 1
ncol2 = UBound(y, 2) - LBound(y, 2) + 1
ReDim matrixmultiply(1 To nrow1, 1 To ncol2)
ReDim temp(1 To nrow1, 1 To ncol2)
For i = 1 To nrow1
For j = 1 To ncol2
d = 2
For k = 1 To col1
temp(i, j) = temp(i, j) + x(i, k) * y(k, j)
Next k
Next j
Next i
matrixmultiply = temp
End Function
Private Sub CommandButton1_Click()
Dim x(1 To 3, 1 To 3) As Double, y(1 To 3, 1 To 3) As Double, z() As Double
Dim i As Integer, j As Integer
For i = 1 To 3
For j = 1 To 3
x(i, j) = Cells(i, j).Value
y(i, j) = Cells(i, j + 5).Value
Next j
Next i
z = matrixmultiply(x, y)
For i = 1 To 3
For j = 1 To 3
Cells(i, j + 12).Value = z(i, j)
Next j
Next i
End Sub
Silly mistake in the line:
For k = 1 To col1
It should, instead, be
For k = 1 To ncol1
Using Option Explicit would have saved a lot of hurt!