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,
Related
I have the below two sheets in an excel file. I need a VBA code that will write in the column Status the value "Completed" but only if the ID is found in Sheet2. So for example, in Sheet1 I want the ID 1 to be with status "Completed", but ID 2 with blank cell in Status, because ID2 cannot be found in Sheet2. I would like to do this with a for each, as it will work faster than a simple IF formula, but I can't seem to find a code that would work. Thank you
Sheet1:
----------------------------------
ID | Product | Date | Status
-----------------------------------
1 | abc | 05-Jan-19 |
2 | abc | 07-Jan-18 |
3 | def | 05-Apr-19 |
4 | ghi | 06-Feb-19 |
Sheet2:
-------------
ID | Product
-------------
1 | abc
3 | def
4 | ghi
Use array is fast.
Sub setStatus()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim rngDB As Range
Dim vDB, vR()
Dim i As Long, n As Long
Set Ws1 = Sheets(1)
Set Ws2 = Sheets(2)
With Ws1
vDB = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
End With
With Ws2
Set rngDB = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
End With
n = UBound(vDB, 1)
ReDim vR(1 To n, 1 To 1)
For i = 1 To n
If WorksheetFunction.CountIf(rngDB, vDB(i, 1)) Then
vR(i, 1) = "Completed"
End If
Next i
Ws1.Range("d2").Resize(n) = vR
End Sub
=IF(ISNA(MATCH(A4;Sheet2!$A$2:$A$6;0));"";"Completed")
A4 is a cell in Status column from Sheet1
$A$2:$A$6 is the range of ids from Sheet2.
Just apply this formula to all cells in Status column from Sheet1.
TheReddsable you can try below code also
Option Explicit
Dim awb, product_id As String
Dim sht_1_count, sht_2_count, loop_i, loop_d As Double
Sub get_status()
awb = ActiveWorkbook.Name
sht_1_count = Workbooks(awb).Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
sht_2_count = Workbooks(awb).Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
For loop_i = 2 To sht_1_count
product_id = Workbooks(awb).Sheets("Sheet1").Cells(loop_i, 1)
For loop_d = 2 To sht_2_count
If LCase(Trim(product_id)) = LCase(Trim(Workbooks(awb).Sheets("Sheet2").Cells(loop_d, 1))) Then
Workbooks(awb).Sheets("Sheet1").Cells(loop_i, 4) = "Completed"
Exit for
End If
Next loop_d
Next loop_i
End Sub
I made the code with the assumption that both ranges start from A1. Please, test it!
Sub BringVal()
Dim sh1 As Worksheet, sh2 As Worksheet, arrCheck As Variant, arrMatch As Variant
Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long, arrRez As Variant
Dim boolF As Boolean
Set sh1 = Sheets(1): Set sh2 = Sheets(2) 'use here your real sheets!
lastRow1 = sh1.Range("A" & sh1.Rows.count).End(xlUp).Row
lastRow2 = sh2.Range("A" & sh2.Rows.count).End(xlUp).Row
arrCheck = sh1.Range("A2:A" & lastRow1).Value
arrMatch = sh2.Range("A2:B" & lastRow2).Value
ReDim arrRez(1 To UBound(arrCheck))
For i = 1 To UBound(arrCheck)
For j = 1 To UBound(arrMatch, 1)
If arrCheck(i, 1) = arrMatch(j, 1) Then
boolF = True
arrRez(i) = arrMatch(j, 2): Exit For
End If
Next j
If Not boolF Then arrRez(i) = Empty
Next i
If UBound(arrRez) > 0 _
Then sh1.Range("D2:D" & UBound(arrRez) + 1).Value = _
WorksheetFunction.Transpose(arrRez)
End Sub
The code should be extremely fast, since it works only in memory and drop all the collected data at once.
If you need a message for the case of not any match found, it is so easy to add an Else ... End If sequence after the last If...
I am looping through a table in Excel with VBA to split the value into the next column. The table looks like this.
+---------------------+---------------------+
| Interval Start Date | Interval Start Time |
+---------------------+---------------------+
| 2019-07-01 04:00 | |
| 2019-07-01 05:00 | |
| 2019-07-01 05:00 | |
| 2019-07-01 05:00 | |
| 2019-07-01 06:00 | |
+---------------------+---------------------+
The first column is A the second is B.
I am using this code that I have written/acquired.
Sub SplitCells()
Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).row).Copy Destination:=Range("B2")
Dim rLastRow As Range
Dim row As Integer
Set ws = Sheets("Monthly Queue activity by hour-")
row = 2
Set rLastRow = Cells(Rows.Count, "B").End(xlUp)
rLastRow = rLastRow - 1
Dim TestArray As Variant
With ws
Do
TestArray = Split(CStr(.Cells(row, 1).Value))
.Cells(row, 2) = TestArray(1)
row = row + 1
Loop Until row = rLastRow
End With
End Sub
It will give me the Subscript Out Of Range if the timestamp I am splitting out is 00:00. I have tried searching and I can't seem to track down how to fix this.
I remove the entries with the 00:00 timestamp and it works, except I still get the Out Of Range when it reaches the end.
Since rLastRow is a range you need to call the .row property to end the Loop. This with the .Text suggestion should do the trick.
Sub SplitCells()
Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).row).Copy Destination:=Range("B2")
Dim rLastRow As Range
Dim row As Integer
Set ws = Sheets("Monthly Queue activity by hour-")
row = 2
Set rLastRow = Cells(Rows.Count, "B").End(xlUp)
rLastRow = rLastRow - 1
Dim TestArray As Variant
With ws
Do
TestArray = Split(CStr(.Cells(row, 1).Text))
.Cells(row, 2) = TestArray(1)
row = row + 1
Loop Until row = rLastRow.row + 1
End With
End Sub
I have an excel sheet with headers in row 1 and values for each of those columns from -2 to 2 in the subsequent rows. I would like to delete a column (including the header) if each row contains the value 0.
Example: I have three columns A, B, and C and 1500 rows. The header for each of these rows are Patient 1, Patient 2, and Patient 3. Patient 3 contains 0 in each of the 1499 rows and I want to have a final spreadsheet with just Patient 1 and Patient 2.
Thanks for your time.
You could try something like this:
Sub RemoveZeroBasedColumns()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4")
Dim iLastCol As Integer
Dim iLastRow As Long
Dim iC As Integer
With oWS
iLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
For iC = 1 To iLastCol
If WorksheetFunction.CountIf(Range(Chr(64 + iC) & ":" & Chr(64 + iC)), 0) = iLastRow Then
.Columns(iC).Delete shift:=xlShiftToLeft
iLastCol = iLastCol - 1
End If
Next
End With
End Sub
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
I have a column of data (F) and a column of numbers (G), and I want to copy each row of column F and paste to column H for a number of times, which depends on the corresponding value in column G.
How could I do it using vba?
For exemple:
F G H
4 Q7-CA 1 Q7-CA
5 Q5-CA 2 Q5-CA
6 A1-CA 1 Q5-CA
7 Q6-CA 4 A1-CA
8 BULK-TACEHU 1 Q6-CA
9 AMA-EG 2 Q6-CA
10 Q6-CA
11 Q6-CA
12 BULK-TACEHU
13 AMA-EG
14 AMA-EG
Use the code below, I used row 1 as the row where the data starts (modify according to your needs) :
Option Explicit
Sub CopyNumofTimes()
Dim LastRow As Long
Dim Sht As Worksheet
Dim lRow As Long
Dim newRow As Long
Dim CopyRep As Integer
Dim cpyRow As Integer
' modify Sheet1 to your Sheet name
Set Sht = ThisWorkbook.Sheets("Sheet1")
' modify 1 form the line number you are starting your data
newRow = 1
With Sht
' find last row with data in Column F
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For lRow = 1 To LastRow
CopyRep = .Cells(lRow, "G").Value
' make sure you have a number of at least 1 in Column G
If CopyRep > 0 Then
For cpyRow = 1 To CopyRep
.Cells(newRow, "H") = .Cells(lRow, "F")
newRow = newRow + 1
Next cpyRow
End If
Next lRow
End With
End Sub