I have written the following code for the fourth worksheet where the number of rows and columns can increase based on the table dimension created in worksheet 1. Here's the code:
Dim sh1 As Worksheet
Set sh1 = Worksheets("Sheet 1")
Dim sh4 As Worksheet
Set sh4 = Worksheets("Sheet 4")
Dim operations As Integer
operations = sh1.Range("D4").Value
Dim contaminants As Integer
contaminants = sh1.Range("D6").Value
Dim firstRow As Integer
firstRow = sh4.Range("B10").Row
Dim operation As Integer
Dim lastRow As Integer
lastRow = firstRow + operations*contaminants - contaminants - operation
Dim b As Integer
b = 0
Dim c As Integer
c = 0
While c <= contaminants - 2
If sh4.Cells(10+b,3+c) = "Count" Then
sh4.Cells(10+b,3+c) = Application.WorksheetFunction.Sum(sh4.Range(sh4.Cells(firstRow, (3+c)), sh4.Cells(lastRow, (3+c))))
Else
b = b + 1
End If
c = c + 1
Wend
The code will do just the part of introducing the sum of defined range whenever it founds in column C the word "Count". Then it prints the value into column D, and advance into column E and so on until reaching contaminants - 2. Basically, I just want to print the result into D16 and E16 and I am not understanding what's wrong with: sh4.Cells(10+b,3+c) = Application.WorksheetFunction.Sum(sh4.Range(sh4.Cells(firstRow, (3+c)), sh4.Cells(lastRow, (3+c))))
C D E
10 1 0 -
11 2 - 1
12 3 1 -
13 4 - 1
14 5 1 -
15 6 - 1
16 Count 2 3
Thank you for your time!
Assumptions made are explained, integers replaced with longs, "Count" row number set in a variable, loop replaced with a for loop.
Dim sh1 As Worksheet
Set sh1 = Worksheets("Sheet 1")
Dim sh4 As Worksheet
Set sh4 = Worksheets("Sheet 4")
Dim operations As Long
operations = sh1.Range("D4").Value
Dim contaminants As Long
contaminants = sh1.Range("D6").Value
Dim firstRow As Long
firstRow = sh4.Range("B10").Row
Dim operation As Long
Dim lastRow As Long
lastRow = firstRow + operations * contaminants - contaminants - operation
Dim CountRow As Long
Dim lng As Long
'Assuming column 3 onwards has "count" and it always exists on the same row
CountRow = Application.Match("Count", sh4.Columns(3), 0)
'Start at column 4, assuming we don't want to overwrite "Count" in column C
For lng = 4 To contaminants - 2
sh4.Cells(CountRow, lng) = Application.WorksheetFunction.Sum(sh4.Range(sh4.Cells(firstRow, lng), sh4.Cells(lastRow, lng)))
Next lng
Related
How can I make this code find all occurrences of the cell value? Right now it iterates and then pastes the same row (first time it appears), it's not moving past that row to find the remaining rows that match the row. Sheet A has the part appear more than once. Any help would be appreciated! Thanks!
Sub Update_Data()
Dim d As Worksheet: Set d = ThisWorkbook.Worksheets("Sheet D")
Dim a As Worksheet: Set a = ThisWorkbook.Worksheets("Sheet A")
' **IMPORTANT** header row locations
Dim d_headerRow As Integer: d_headerRow = 1
Dim a_headerRow As Integer: a_headerRow = 1
Dim i As Long, j As Long, k As Integer, part As String
Dim d_lastRow As Long: d_lastRow = d.Cells(d.Rows.Count, 1).End(xlUp).Row
Dim a_lastRow As Long: a_lastRow = a.Cells(a.Rows.Count, 1).End(xlUp).Row
Dim a_lastCol As Integer: a_lastCol = a.Cells(a_headerRow, a.Columns.Count).End(xlToLeft).Column
For i = d_headerRow + 1 To d_lastRow
part = d.Cells(i, 1).Value
For j = a_headerRow + 1 To a_lastRow
If part = a.Cells(j, 1).Value Then
a.Range(a.Cells(j, 1), a.Cells(j, a_lastCol)).Copy Destination:=d.Range(d.Cells(i, 11), d.Cells(i, 11))
Exit For
End If
Next j
Next i
End Sub
I have a simple table with 3 rows and 3 columns:
Column 1 - Order #, Column 2 - Part #, Column 3 - Quantity
Row 1: 123 | ABC | 5
Row 2: 456 | XYZ | 7
Row 3: 789 | OPQ | 2
How can I set up either a formula (preferably) or VBA to automatically populate, in a separate sheet:
5 rows of 123 | ABC, followed by
7 rows of 456 | XYZ, followed by
2 rows of 789 | OPQ
Thanks in advance,
Below is a small VBA procedure that gets all of the data from the first worksheet and puts it into an array. It then loops this array, performing a loop on the last element to create the required number of rows for each Order/Part:
Sub sExpandData()
Dim wsIn As Worksheet
Dim wsOut As Worksheet
Dim lngLastRow As Long
Dim aData() As Variant
Dim lngLoop1 As Long
Dim lngLoop2 As Long
Dim lngRow As Long
Set wsIn = ThisWorkbook.Worksheets("Data")
Set wsOut = ThisWorkbook.Worksheets("Expanded")
lngLastRow = wsIn.Cells(wsIn.Rows.Count, "A").End(xlUp).Row
aData = wsIn.Range("A1:C" & lngLastRow)
lngRow = 1
For lngLoop1 = LBound(aData, 1) To UBound(aData, 1)
For lngLoop2 = 1 To aData(lngLoop1, 3)
wsOut.Cells(lngRow, 1) = aData(lngLoop1, 1)
wsOut.Cells(lngRow, 2) = aData(lngLoop1, 2)
lngRow = lngRow + 1
Next lngLoop2
Next lngLoop1
Set wsIn = Nothing
Set wsOut = Nothing
End Sub
Regards,
I am working on the code where I want to write 2 arrays (assigned in 'Input sheet) to 'Output' sheet n times, i.e. specifically 2 times in the loop. I want to use arrays because the range of the ids and its names can change (it can be much more).
To start with a simple example (with a small amount of data), the arrays are assigned acc. to data in 'Input' sheet:
These 2 arrays should be written to 'Output' sheet n times i.e.; They should be written once and then again in the loop i.e. 2 times. I want to do it in the loop to give it the flexibility of writing in the future e.g. 3, 4, n times. In this example, I do it 2 times. Before each written array, there should be written a heading 'Title' and at the end of the written array should written text 'Total', therefore this is my desired outcome:
My code works only to write the 2 arrays for the first time but it does not write these 2 arrays for 2nd time. Instead, I am getting something else which is wrong:
This is my code:
Sub Write1()
Dim r As Long
Dim c As Long
Dim Start_Row As Long
Dim End_Row As Long
Dim main As Integer
Dim lngRowCount As Long
Dim w_Output As Worksheet
Dim w1 As Worksheet
Dim intLastRow As Integer
Const RowStart As Integer = 3
Const ColumnID As Integer = 1
Const Column_Desc As Integer = 3
Dim arrID() As Variant
Dim arrDesc() As Variant
With ThisWorkbook
Set w1 = .Sheets("Input")
Set w_Output = .Sheets("Output")
End With
'***********************************
'arrays
With w1
intLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'IntLastCol = .Cells(4, Columns.Count).End(xlToLeft).Column
arrID = .Range(.Cells(RowStart, ColumnID), .Cells(intLastRow, ColumnID))
arrDesc = .Range(.Cells(RowStart, Column_Desc), .Cells(intLastRow, Column_Desc))
'******************************************
main = 1
End_Row = 2 'this is the 2nd iteration to write arrays
For Start_Row = 1 To End_Row
w_Output.Cells(main, 3) = "Title"
main = main + 1
For r = 1 To UBound(arrID, 1)
If Len(arrID(r, 1)) > 0 Then
'Write
w_Output.Cells(r + 1, 3) = arrID(r, 1)
w_Output.Cells(r + 1, 4) = arrDesc(r, 1)
End If
main = main + 1
w_Output.Cells(main, 3) = "Total "
Next r
main = main + 4
Next Start_Row
End With
MsgBox "Done", vbInformation
End Sub
Does anybody know what I do wrong in my loop to make it work?
I have figured it out, it turns out the I was simply supposed to use 'main' as the row to write to the sheet and not 'r' which is used for the arrays - this is part of the code where arrays are written to the sheet.
Sub Write1()
Dim r As Long
Dim c As Long
Dim d As Long
Dim Start_Row As Long
Dim End_Row As Long
Dim main As Integer
Dim lngRowCount As Long
Dim w_Output As Worksheet
Dim w1 As Worksheet
Dim intLastRow As Integer
Dim IntLastCol As Integer
Const RowStart As Integer = 3
Const ColumnID As Integer = 1
Const Column_Desc As Integer = 3
Dim arrID() As Variant
Dim arrDesc() As Variant
With ThisWorkbook
Set w1 = .Sheets("Input")
Set w_Output = .Sheets("Output")
End With
'***********************************
'arrays
With w1
intLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
arrID = .Range(.Cells(RowStart, ColumnID), .Cells(intLastRow, ColumnID))
arrDesc = .Range(.Cells(RowStart, Column_Desc), .Cells(intLastRow, Column_Desc))
'******************************************
main = 1
End_Row = 2
For Start_Row = 1 To End_Row
w_Output.Cells(main, 3) = "Title"
main = main + 1
For r = 1 To UBound(arrID, 1)
If Len(arrID(r, 1)) > 0 Then
'Write
w_Output.Cells(main, 3) = arrID(r, 1)
w_Output.Cells(main, 4) = arrDesc(r, 1)
End If
main = main + 1
Next r
w_Output.Cells(main, 3) = "Total "
main = main + 4
Next Start_Row
End With
MsgBox "Done", vbInformation
End Sub
It works perfectly.
I am trying to build an Excel workbook that takes data from one sheet, and fills out another based on a system name. I am having a problem with the first for next loop. It works for the first system, but if there are more than one item in the system it just stops working. The second for each loop works great. Is there a better way to run my first loop. I try an if the first For each variable matches the second for each then increment, but the code says the next Inspectcell does not have a for each. The system name is always in column C and starts at C7
Sub fillthereport()
Dim xx As Variant, ws As Variant, yy As Variant
Dim ws2 As Variant, xxx As Variant, yyy As Variant
Dim rowed As Integer, b As Integer
'Dim MySht As Worksheet
Dim MyPic As Shape
Dim MyLeft As Single, MyTop As Single
Dim conv As Variant
Dim item As Variant
Dim picnum As Variant
Dim mergecells As String, mergecells2 As String, mergecolor As String
Dim horstart As Variant, horend As Variant
Dim verstart As Variant, verend As Variant
Dim Inspectcell As Range, reportcell As Range
'worksheets loop operator
ws = 1
'worksheets loop operator to
ws2 = 6
'row designator from
xx = 7
'column designator from
yy = 3
'row designator to
xxx = 68
'column designator to
yyy = 37
'This is not the variable you are looking for
b = 0
'These are the variables you are looking for
yel = 0
bl = 0
re = 0
Folderpath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
reportcell = Worksheets("inspection Data").Range("C7")
'make extra sheets in the report to be filled
For Each Inspectcell In Worksheets("inspection Data").Range("C7:C18")
If Inspectcell = reportcell Then
Worksheets(ws2).Select
Worksheets(ws2).Range("A60:AY114").Select
Selection.Copy
Sheets(ws2).Range("A115:AY169").Select
ActiveSheet.Paste
Sheets(ws2).Range("A170:AY224").Select
ActiveSheet.Paste
'reportcell = Inspectcell
For Each reportcell In Worksheets("inspection Data").Range("C7:C18")
If reportcell = Inspectcell Then
'(This is about 110 lines of code that work great)
xx = xx + 1
b = b + 1
'worksheets loop operator
'ws = ws + 1
'worksheets loop operator to
'ws2 = ws2 + 1
'column designator from
'yy = yy + 1
'row designator to
If Not b Mod 3 = 0 Then
xxx = xxx + 16
Else
xxx = xxx + 23
End If
Else 'If xx = 15 Then
Exit For
End If
'xxx = xxx + 22
Next reportcell
ws2 = ws2 + 1
'Else
'Exit for
End if
Next Inspectcell
I have looked for some pseudo code for this, but cannot find it. Any help would be appreciated. Basically I would like to take sample data like:
1 A 2 B 3 C
4 D 5 E 6 F
and copy it to a new sheet as:
1 A
2 B
3 C
4 D
5 E
6 F
According to your picture, we're copying everything in the worksheet. This will work for that case. If it's a subset, please try to modify rngSource to meet your needs:
Sub FlattenAndCopy()
Dim wsSource As Excel.Worksheet
Dim rngSource As Excel.Range
Dim varSource As Variant
Dim wsTarget As Excel.Worksheet
Dim SourceCount As Long
Dim varTarget() As Variant
Dim i As Long, j As Long
Set wsSource = ActiveSheet
Set rngSource = wsSource.UsedRange
varSource = rngSource.Value
SourceCount = rngSource.Cells.Count
ReDim varTarget(1 To SourceCount)
For i = LBound(varSource, 1) To UBound(varSource, 1)
For j = LBound(varSource, 2) To UBound(varSource, 2)
varTarget((i - 1) * (UBound(varSource, 2)) + j) = varSource(i, j)
Next j
Next i
Set wsTarget = wsSource.Parent.Worksheets.Add
wsTarget.Cells(1).Resize(SourceCount, 1) = Application.WorksheetFunction.Transpose(varTarget)
End Sub