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
Related
I have written a macro to expand a range of start/stop dates by 5 minute increments and assigning a "campaign" number to each set of dates. For example, I have a table of dates:
Start
Stop
8/19/15 17:20
8/20/15 2:20
12/13/16 7:30
12/14/16 18:00
5/29/20 22:00
5/31/20 1:00
I want to expand each date range into a table at 5 minute increments (ie, 8/19/15 17:20, 8/19/15 17:25) then assign a label to each set (everything between 8/16/15 17:20 - 8/20/15 2:20 would be considered Campaign 1). I wrote the following code that works as planned, but when the macro gets to the 23:55 hour, the subsequent date is midnight of the previous day:
Date
8/19/15 23:50
8/19/15 23:55
8/19/15 00:00
8/20/15 00:05
Any thoughts on how to prevent the previous day showing up here?
Thanks
The code:
Sub campaignpull()
Dim ROWID As Integer
Dim LASTROW As Long
Dim rng As Range
Dim StartRng As Range
Dim EndRng As Range
ThisWorkbook.Sheets("Sheet1").Activate
LASTROW = ActiveSheet.UsedRange.Rows.Count
For ROWID = 2 To LASTROW
Set StartRng = Cells(ROWID, 1)
Set EndRng = Cells(ROWID, 2)
For i = StartRng To EndRng Step 1 / 24 / 12
ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = i
ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = ROWID - 1
Next
Next ROWID
End Sub
it seems Excel handles Date/Time in a different way than VBA. The solution I found was to use Excel formulas to create the 5 minutes increments. Please take a look at the code below:
Sub CampaignPull()
Dim rowCount As Integer
rowCount = Evaluate("COUNTA(Sheet1!A:A)")
Dim i As Integer
Dim j As Integer
j = 2
Dim startDateTime As Date
Dim endDateTime As Date
For i = 2 To rowCount
startDateTime = Sheets("Sheet1").Range("A" & i)
endDateTime = Sheets("Sheet1").Range("B" & i)
Sheets("Sheet2").Range("A" & j) = startDateTime
Do
j = j + 1
Sheets("Sheet2").Range("A" & j).Formula = "=A" & (j - 1) & "+1/12/24"
Loop While Sheets("Sheet2").Range("A" & j) <= endDateTime
Next i
End Sub
My take, although prior answer was good.
Do as you like with columns:
Sub campaignpull()
Dim rowId As Integer
Dim lastRow As Long
Dim rng As Range
Dim currentTime As Date
Dim endTime As Date
Dim i As Date
Dim rw As Integer
Sheet1.Activate
lastRow = ActiveSheet.UsedRange.Rows.Count
For rowId = 2 To lastRow
currentTime = Sheet1.Cells(rowId, 1).Value
endTime = Sheet1.Cells(rowId, 2).Value
rw = 1
Do Until currentTime > endTime
currentTime = currentTime + 1 / 24 / 12
Sheet2.Cells(rw, rowId) = currentTime
rw = rw + 1
Loop
Next rowId
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 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'm trying to copy rows from one worksheet to another based on whether a string exists in a specific cell of each row. In the below example, I'm searching for Jordan in Column J. If that name is in this particular rows Column J, it gets moved to a different sheet (Final Sheet).
Sub Test()
Worksheets("All Data").Activate
Dim N As Long, i As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To N
If InStr(1, Cells(i, "J"), "Jordan") > 0 Then
Worksheets("All Data").Rows(i).Copy
Worksheets("Final Sheet").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
End Sub
What I want to do is look for multiple strings. I can accomplish this by adding as many "Or" are needed like below.
If InStr(1, Cells(i, "J"), "Jordan") > 0 Or InStr(1, Cells(i, "J"), "Barkley") > 0 Then
I usually have 5+ strings i'm searching for and it becomes difficult to update the code each time. I would rather the strings I look for be located in a range of cells on some hidden sheet that I or someone can update easily. I've been tinkering with the below. Range does work if its a single cell. If its more such as A1:A5 then it breaks. Any thoughts on how I could accomplish this? Am I totally missing an elegant solution?
Sub Test()
Worksheets("All Data").Activate
Dim N As Long, i As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To N
If InStr(1, Cells(i, "J"), Worksheets("List").Range("A1:A5")) > 0 Then
Worksheets("All Data").Rows(i).Copy
Worksheets("Final Sheet").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
End Sub
List Sheet
- | A |
1 | Jordan |
2 | Barkley |
3 | Batman |
4 | Robin |
5 | Ozzy |
Based on this previous answer, I customize it to your scenario
Remember to backup your data before running it.
Read the code's comments and adjust the variables' values to fit your needs.
Public Sub CopyData()
' Define the object variables
Dim sourceWorksheet As Worksheet
Dim targetWorksheet As Worksheet
Dim listRange As Range
Dim evalCell As Range
' Define other variables
Dim listRangeAddress As String
Dim startSourceRow As Long
Dim lastSourceRow As Long
Dim columnForLastRowSource As Long
Dim lastTargetRow As Long
Dim sourceRowCounter As Long
Dim columnForLastRowTarget As Long
Dim columnToEval As Long
''''' Adjust the folloing values ''''
' Set the lookup list range address
listRangeAddress = "B1:B5"
' Adjust the worksheets names
Set sourceWorksheet = ThisWorkbook.Worksheets("All Data")
Set targetWorksheet = ThisWorkbook.Worksheets("Final Sheet")
Set listRange = ThisWorkbook.Worksheets("List").Range(listRangeAddress)
' Set the initial row where data is going to be evaluated
startSourceRow = 1
' Set the column from which you're going to get the last row in sourceSheet
columnForLastRowSource = 1
' Set the column from which you're going to get the last row in targetSheet
columnForLastRowTarget = 1
' Set the column where you evaluate if condition is met
columnToEval = 10
'''''''Loop to copy rows that match'''''''
' Find the number of the last row in source sheet
lastSourceRow = sourceWorksheet.Cells(sourceWorksheet.Rows.Count, columnForLastRowSource).End(xlUp).Row
For sourceRowCounter = startSourceRow To lastSourceRow
For Each evalCell In listRange.Cells
' Evaluate if criteria is met in column
If InStr(sourceWorksheet.Cells(sourceRowCounter, columnToEval).Value, evalCell.Value) > 0 Then
' Get last row on target sheet (notice that this search in column A = 1)
lastTargetRow = targetWorksheet.Cells(targetWorksheet.Rows.Count, columnForLastRowTarget).End(xlUp).Row
' Copy row to target
sourceWorksheet.Rows(sourceRowCounter).Copy targetWorksheet.Rows(lastTargetRow + 1)
' If found, don't keep looking
Exit For
End If
Next evalCell
Next sourceRowCounter
End Sub
Let me know if it works and remember to mark the answer if it does.
Creating macros in Excel is not my strong point so I'm wondering if someone is able to help.
I have a small table with product values, though not every cell has a value. What I'm trying to do is write a macro to create a list on a separate sheet. The macro I have written works for the first column but that's where it stops.
For example
List | aa | bb | cc
a |1 | 15 | -
b |2 | 23 | 12
c |- | 17 | 5
d |4 | - | -
Should appear on Sheet 2 like so
- List| aa
- a | 1
- b | 2
- d | 4
- List| bb
- a | 15
- b | 23
- c | 17
- List| cc
- b | 12
- c | 5
At the moment, only aa shows correctly on the 2nd sheet and none of the other columns.
The macro I have so far is
Sub Button2_Click()
Dim Column As Integer
Column = 1
newrow = 1
Do Until Worksheets("Sheet1").Cells(Column, 1).Value = ""
If Worksheets("Sheet1").Cells(Column, 2).Value <> "" Then
Worksheets("Sheet2").Cells(newrow, 1).Value = Worksheets("Sheet1").Cells(Column, 1).Value
Worksheets("Sheet2").Cells(newrow, 2).Value = Worksheets("Sheet1").Cells(Column, 2).Value
newrow = newrow + 1
End If
Column = Column + 1
Loop
End Sub
This is what I was suggesting. This code sample is based on the above sample data. If the structure of the sample changes then you will have to amend the code accordingly. I have commented the code so that you shouldn't have a problem understanding it. But if you do, simply post back :)
CODE
Option Explicit
Sub Sample()
'~~> Input/Output Sheets
Dim wsI As Worksheet, wsO As Worksheet
Dim Lrow As Long, ORow As Long, i As Long
Dim rngToFilter As Range
'~~> Set the input, output sheets
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
'~~> Set the output row in the new sheet
ORow = 1
With wsI
'~~> Get last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rngToFilter = .Range("A1:D" & Lrow)
'~~> Hide Col C to E
.Range("C:E").EntireColumn.Hidden = True
'~~> Loop through Col B to Col D
For i = 2 To 4
'~~> Remove any filters
.AutoFilterMode = False
'~~> Copy Header viz List| aa, List| bb
Union(.Cells(1, 1), .Cells(1, i)).Copy wsO.Range("A" & ORow)
'~~> Get next empty row
ORow = ORow + 1
'~~> Filter, offset(to exclude headers) and copy visible rows
With rngToFilter
.AutoFilter Field:=i, Criteria1:="<>"
'~~> Copy the filtered results to the new sheet
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy wsO.Range("A" & ORow)
End With
ORow = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
'~~> Unhide/Hide relevant columns
.Columns(i).EntireColumn.Hidden = True
.Columns(i + 1).EntireColumn.Hidden = False
'~~> Remove any filters
.AutoFilterMode = False
Next i
'~~> Unhide all columns
.Range("B:E").EntireColumn.Hidden = False
End With
End Sub
SCREENSHOT