Looping & If not working for the second instruction - excel

I'm relatively new in Excel VBA and what i'm doing is a loader for one of our ERPs. So my problem is this...I have an excel worksheet, let's call it the origin and another one, let's call it dummy.
What i want to do is for the macro to check if a certain cell (af18) in origin range falls into criteria. If its true, then copy a A18 from origin sheet to dummy sheet. Then insert "{tab} on the next column. then if AF19 (the next cell) falls into the criteria, copy the a19 to dummy's next blank column then again insert {tab}.
The current code produces this: 1,2,3...\{tab}
But I want it to be like this: 1,\{tab},2,\{tab}...
Sub CreateLoaderBeta()
Dim origin As Worksheet
Dim destination As Worksheet
Dim desrow As Long
Dim descol As Long
Dim descolstart As Long
Dim origrow As Long
Dim origcol As Long
Dim rang As Range
Dim C As Range
Dim qual As Integer
Set origin = Sheets("1")
Set destination = Sheets("dummy")
desrow = 3
descol = 1
origrow = 18
origcol = 32
Set rng = Sheets("1").Range("AF18:af47")
total = WorksheetFunction.SUM(Worksheets("1").Range("AF18:AF47"))
descolstart = destination.cells(desrow, Columns.Count).End(xlToLeft).column
If total > 0 Then
'Dim headcol As Integer
'headcol = 1
'origin.cells(3, headcol).Copy
'destination.cells(1, descolstart).PasteSpecial Paste:=xlPasteValues
For Each C In rng
If C = 14 Then
origin.cells(origrow, 1).Copy
destination.cells(1, descolstart).PasteSpecial Paste:=xlPasteValues
destination.cells(1, descolstart + 1).Value = "\{TAB}"
descolstart = descolstart + 1
origrow = origrow + 1
End If
Next C
destination.Columns("A:U").insert Shift:=xlToRight
Call headers
Else 'Donothing
End If
MsgBox total
End Sub**

destination.cells(1, descolstart).PasteSpecial Paste:=xlPasteValues
destination.cells(1, descolstart + 1).Value = "\{TAB}"
descolstart = descolstart + 1
You are overwriting the "\{TAB}" you just wrote, in the next iteration. The descolstart must be incremented by 2 at each iteration because each iteration consumes two columns.
descolstart = descolstart + 2 ' <------------ +2, not +1

Related

Can I give an if statement by subtracting time?

Is there a way to make my VBA code work for my macro? I want my macro's if function to read the first column of each worksheet in my excel (it has as many sheets as days in the exact month i'm working on), read through each cell and if the currently read cell is equal to or larger than '15 minutes compared to the first cell, then the code would execute, otherwise go to the next cell in the first column.
This is the format of the worksheets i'm working on:
TimeStamp
Power Consumption
Power Production
Inductive Power Consumption
2021.01.01. 8:12:38 +00:00
747
575
3333
2021.01.01. 8:17:35 +00:00
7674
576
3333
... etc ,
And my code looks something like this:
Sub stackoverflow()
Dim w As Integer 'index of worksheets
Dim i As Integer 'row index that steps through the first column
Dim t As Integer 'reference row index i inspect the time to
Dim x As Integer 'row index where i want my data to be printed
Dim j As Integer 'col index
Dim Timediff As Date 'not sure if this is even needed
t = 2
j = 1
x = 1
'Timediff = ("00:15:00")
For w = 3 To ActiveWorkbook.Worksheets.Count 'for every sheet from the 3rd to the last
lRow = ActiveWorkbook.Worksheets(w).Cells(Rows.Count, 1).End(xlUp).Row 'find the last row in each worksheet
lCol = ActiveWorkbook.Worksheets(w).Cells(1, Columns.Count).End(xlToLeft).Column 'find the last column in each worksheet
For x = 2 To lRow
For i = 2 To lRow
'If the time in cell(i,j) is >= then cell(t,j) + 15 minutes,
If Cells(i, j) >= DateAdd("n", 15, Cells(t, j)) Then
ActiveWorkbook.Worksheets(w).Range(i, j).Copy ActiveWorkbook.Worksheets(2).Range(x, j)
ActiveWorkbook.Worksheets(w).Range(i, j + 1).Copy ActiveWorkbook.Worksheets(2).Range(x, j + 1)
'put the new reference point after the found 15 minute mark
t = i + 1
Else
End If
Next i
Next x
Next w
End Sub
So all in all I want my code to notice when the first column reaches a 15 minute mark, and execute some code (subtracting the values of the 15 minute mark from the reference where it started, put the value in the'2nd sheet, and then step to the next cell, and repeat the process).
I'm not entirely sure which information you are attempting to copy to the second worksheet but the following code should be able to get you there pretty easily. Additionally, I've added a function that will fix the format of your TimeStamp field so that excel will recognize it and we can then do math with it
Sub TestA()
Dim xlCellA As Range
Dim xlCellB As Range
Dim xlCellC As Range
Dim i As Integer
Dim j As Integer
Dim lRow As Long
Dim lCol As Long
Set xlCellA = ActiveWorkbook.Worksheets(2).Cells(2, 1)
For i = 3 To ActiveWorkbook.Worksheets.Count
lRow = ActiveWorkbook.Worksheets(i).Cells.SpecialCells(xlCellTypeLastCell).Row
lCol = ActiveWorkbook.Worksheets(i).Cells.SpecialCells(xlCellTypeLastCell).Column
Set xlCellB = ActiveWorkbook.Worksheets(i).Cells(2, 1)
xlCellB.Value = FixFormat(xlCellB.Value)
xlCellB.Offset(0, lCol + 1).Value = "=DATEVALUE(MID(" & xlCellB.Address & ",1,10))+TIMEVALUE(MID(" & xlCellB.Address & ",12,8))"
For j = 3 To lRow
Set xlCellC = ActiveWorkbook.Worksheets(i).Cells(j, 1)
xlCellC.Value = FixFormat(xlCellC.Value)
xlCellC.Offset(0, lCol + 1).Value = "=DATEVALUE(MID(" & xlCellC.Address & ",1,10))+TIMEVALUE(MID(" & xlCellC.Address & ",12,8))"
If xlCellC.Offset(0, lCol + 1) - xlCellB.Offset(0, lCol + 1) >= ((1 / 24) / 4) Then
With xlCellA
.Value = xlCellC.Value
.Offset(0, 1).Value = xlCellC.Offset(0, 1).Value
End With
Set xlCellA = xlCellA.Offset(1, 0)
End If
Next j
Next i
Set xlCellA = Nothing
Set xlCellB = Nothing
Set xlCellC = Nothing
End Sub
Private Function FixFormat(ByVal dStr As String) As String
Dim tmpStr As String
Dim i As Integer
For i = 1 To Len(dStr)
If Mid(dStr, i, 1) <> "." Then
tmpStr = tmpStr & Mid(dStr, i, 1)
Else
If Mid(dStr, i + 1, 1) <> " " Then tmpStr = tmpStr & "-"
End If
Next i
FixFormat = tmpStr
End Function
It's not really clear what needs to happen when the 15min threshold is met but this should get you most of the way there:
Sub stackoverflow()
Dim w As Long, Timediff As Double
Dim wb As Workbook, wsData As Worksheet, wsResults As Worksheet, col As Long
Dim baseRow As Range, dataRow As Range, rngData As Range, resultRow As Range
Timediff = 1 / 24 / 4 '(15min = 1/4 of 1/24 of a day)
Set wb = ActiveWorkbook 'or ThisWorkbook
Set wsResults = wb.Worksheets("Results")
'first row for recording results
Set resultRow = wsResults.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow
For w = 3 To wb.Worksheets.Count 'for every sheet from the 3rd to the last
Set rngData = wb.Worksheets(w).Range("A1").CurrentRegion 'whole table
Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1) 'exclude headers
Set baseRow = rngData.Rows(1) 'set comparison row
For Each dataRow In rngData.Rows 'loop over rows in data
If (dataRow.Cells(1).Value - baseRow.Cells(1).Value) > Timediff Then
resultRow.Cells(1).Value = dataRow.Cells(1) 'copy date
For col = 2 To dataRow.Cells.Count 'loop columns and subtract
resultRow.Cells(col).Value = _
dataRow.Cells(col).Value - baseRow.Cells(col).Value
Next col
Set resultRow = resultRow.Offset(1, 0)
Set baseRow = dataRow.Offset(1, 0) 'reset comparison row to next row
End If
Next dataRow
Next w
End Sub

Insert new rows to separate groups of data via a for loop

I'm using a for loop but I'm open suggestions if there's a better way to separate the data!
I want to insert two new rows whenever the integer in Column 11 or "K" changes. Column K represents groups of data and each is named with integers between 1 and 10 (inclusive). Each group varies in size, hence why I wanted a for loop to check each time the group increments to trigger the insertion of the rows.
For example:
From the data below two blank rows should be inserted below K11 and below K18. This will result in the data being separated by two blank rows whenever two groups were 'touching' each other.
K2 = 1, K3 = 1, K4 = 1 ... K11 = 1
K12 = 2, K13 = 2, K14 = 2... K18 = 2
K19 = 3, K20 = 3 ...
I've put together the following for loop but it inserts 500 (the counter limit) rows after the first group and no row inserts for the remaining groups. Can you explain why this happens and how I can work around this?
Dim LCounter As Integer
For LCounter = 2 To 500
If Cells(LCounter + 1, 11).Value <> Cells(LCounter, 11) Then
Rows(LCounter + 1).Insert shift:=xlShiftDown
End If
Next LCounter
Try this way, please. It should be very fast even for big ranges:
Sub SeparateGroupsByEmptyRows()
Dim LCounter As Long, col As Long, rng As Range
col = 11
For LCounter = 2 To 500
If cells(LCounter + 1, col).Value <> cells(LCounter, col).Value Then
If rng Is Nothing Then
Set rng = cells(LCounter + 1, col)
Else
Set rng = Union(rng, cells(LCounter + 1, col))
End If
End If
Next LCounter
'For the case of two or more consecutive groups of only one row each:
If InStr(rng.Address(0, 0), ":") > 0 Then Set rng = makeDiscontinuu(rng)
rng.EntireRow.Insert Shift:=xlDown
End Sub
Function makeDiscontinuu(rng As Range) As Range
Dim A As Range, c As Range, strAddress As String
For Each A In rng.Areas
If A.cells.count = 1 Then
strAddress = strAddress & A.Address(0, 0) & ","
Else
For Each c In A.cells
strAddress = strAddress & c.Address(0, 0) & ","
Next c
End If
Next A
Set makeDiscontinuu = Range(left(strAddress, Len(strAddress) - 1))
End Function
try this, should be one empty row separation (not tested)
Dim LCounter As Integer, lcEnd as integer: lcEnd =500
For LCounter = 2 To lcEnd
If Cells(LCounter + 1, 11).Value <> Cells(LCounter, 11) and Cells(LCounter + 1, 11)<> "" Then
Rows(LCounter + 1).Insert shift:=xlShiftDown
lcEnd =lcEnd +1
End If
Next LCounter
Insert Rows Before Change of Cell Value
The first procedure uses For...Next to solve the problem by looping backwards.
The second procedure uses Do...Loop illustrating the complications when looping forwards.
The Code
Option Explicit
Sub insertBeforeChangeForNext()
Const iRows As Long = 2 ' Number of Rows to Insert
Const cCol As Long = 11 ' Criteria Column
Const fRow As Long = 2 ' First Row
' Either...
Const lRow As Long = 500 ' Last Row
' ...or rather determine the last non-empty row:
'Dim lRow As Long: lRow = Cells(Rows.Count, cCol).End(xlUp).Row ' LR
If lRow <= fRow Then
Exit Sub
End If
Application.ScreenUpdating = False
Dim LCounter As Long ' Rows Counter
For LCounter = lRow - 1 To fRow Step -1
If Cells(LCounter + 1, cCol).Value <> Cells(LCounter, cCol).Value Then
Rows(LCounter + 1).Resize(iRows).Insert
End If
Next LCounter
Application.ScreenUpdating = True
End Sub
Sub insertBeforeChangeDoLoop()
Const iRows As Long = 2 ' Number of Rows to Insert
Const cCol As Long = 11 ' Criteria Column
Const fRow As Long = 2 ' First Row
' Either...
Const lRow As Long = 500 ' Initial Last Row
' ...or rather determine the last non-empty row:
'Dim lRow As Long: lRow = Cells(Rows.Count, cCol).End(xlUp).Row ' ILR
Dim Current As Long: Current = fRow ' Current Row
Dim Last As Long: Last = lRow ' Current Last Row
Application.ScreenUpdating = False
Do While Current < Last
If Cells(Current + 1, cCol).Value <> Cells(Current, cCol).Value Then
Rows(Current + 1).Resize(iRows).Insert
Last = Last + iRows
Current = Current + iRows
End If
Current = Current + 1
Loop
Application.ScreenUpdating = True
End Sub

How to auto number till merge cell is detected?

My knowledge in VBA coding is zero. I wonder if someone can help with this question, please.
I have this initial code tried to write but it is wrong. I was not sure how to add these below conditions in the code.
Question: I want to auto number column A which starts at a specific Cell, A3 and it auto-numbers as long as there is text in Column B and Column C.
Here's the sample data picture. Thanks in advance!
Sub test()
Set r = Range("a3", Range("b" & Rows.Count).End(xlUp)).Offset(, -1)
With r
If .MergeCells <> True Then
r = r +1
Else
' Skip
End With
End Sub
Assuming your sheet is named Sheet1, you may use something like this:
Sub Test()
Dim lastRow As Long, i As Long, counter As Long
With Sheet1
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 3 To lastRow
If Not IsEmpty(.Cells(i, 2)) And Not IsEmpty(.Cells(i, 3)) Then
counter = counter + 1
.Cells(i, 1).Value = counter
End If
Next
End With
End Sub
Note: Using IsEmpty to check if any of the cells in columns B & C is empty already covers the case of cells being merged because in that case, at least one of the two cells has to be empty anyway.
Demo:
You have r as a range, you can't add a number to it and have it increment the range. (Though I did just test it and it doesn't throw an error which is strange)
Also Skip is not a thing in VBA, if you want to skip in a loop you need a conditional or a goto. Though you have no loop.
Sub test()
Dim i As Long
Dim lastrow As Long
Dim counter As Long
counter = 1
With ActiveSheet ' Change this to the real sheet name
lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row ' Gets Last row
For i = 3 To lastrow ' Loop
If not isempty(.Cells(i, 2).Value) And not IsEmpty(.Cells(i, 3).Value) Then ' Looks for Text
If Not .Cells(i, 1).MergeCells Then ' Looks for merged cells
.Cells(i, 1).Value = counter ' Adds count
counter = counter + 1 ' Increments count
End If
End If
Next i
End With
See for comments and customize to fit your needs:
Public Sub AutoNumber()
' Declare objects
Dim evalRange As Range
Dim evalCell As Range
' Declare other variables
Dim sheetName As String
Dim initialCellAddress As String
Dim lastRow As Long
Dim columnNumber As Long
Dim counter As Long
' Customize to fit your needs
sheetName = "Sheet1"
initialCellAddress = "B2"
counter = 1
' Get column number and last row number to define the range address ahead
columnNumber = Range(initialCellAddress).Column
lastRow = ThisWorkbook.Worksheets(sheetName).Cells(Rows.Count, columnNumber).End(xlUp).Row
' Define the range to be evaluated
Set evalRange = ThisWorkbook.Worksheets(sheetName).Range(initialCellAddress & ":" & Left$(initialCellAddress, 1) & lastRow)
' Loop through each cell in range (in the original example we'll loop through column b)
For Each evalCell In evalRange
If evalCell.MergeCells <> True Then
' Assign the counter to the column at the left (offset = -1) of the evaluated cell
evalCell.Offset(rowoffset:=0, columnOffset:=-1).Value2 = counter
counter = counter + 1
End If
Next evalCell
End Sub

Setting cell equal to random value if cell isn't blank in range

At a high level I am trying to set a cell equal to a random cell within a range. The issue I am having is that in this range I want to pull a random Value from, the Value I am taking is the result of an 'if' expression that either sets the cell to a Value or "". So when I chose the random value I only want to choose cells that have an actual value, not the "".
Does anyone know how to get this expected behavior?
The code below shows what I have tried currently, each large block is commented to help with understanding. The block I need help with replaces the values in each column until the next cell is blank then moves to the next column.
upperBound = 1798
lowerBound = 2
Randomize
'This loop section populates the data area with a static value in cell 9,3 then 9,4 etc..
For j = 3 To 15
val = Cells(9, j).Value
For i = 1 To val
Cells(12 + i, j).Value = Cells(9, j)
Next i
Next j
'This loop section uses the cells already populated down each column and replaces that value with the random value from the other range
Dim x As Integer
' Set numrows = number of rows of data.
For j = 3 To 15
NumRows = Range(Cells(13, j), Cells(13, j).End(xlDown)).Rows.Count
' Select cell 13,j.
Cells(13, j).Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
ActiveCell.Value = Worksheets("2017 Role IDs").Cells(Int((upperBound - lowerBound + 1) * Rnd + lowerBound), 2).Value
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
Next j
This is the data before the second block runs. I want to replace the values that just match the number in the second row with the random number in the range:
This is what I would like to look like:
But currently it looks like this because the random selector is taking blank values:
Something like this should work for you:
Sub tgr()
Dim wb As Workbook
Dim wsNums As Worksheet
Dim wsDest As Worksheet
Dim aData As Variant
Dim vData As Variant
Dim aNums() As Double
Dim aResults() As Variant
Dim lNumCount As Long
Dim lMaxRows As Long
Dim lRowCount As Long
Dim ixNum As Long
Dim ixResult As Long
Dim ixCol As Long
Set wb = ActiveWorkbook
Set wsNums = wb.Worksheets("2017 Role IDs")
Set wsDest = wb.ActiveSheet
With wsNums.Range("B2", wsNums.Cells(wsNums.Rows.Count, "B").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
lNumCount = WorksheetFunction.Count(.Cells)
If lNumCount = 0 Then Exit Sub 'No numbers
ReDim aNums(1 To lNumCount)
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Value
Else
aData = .Value
End If
'Load populated numeric cells into the aNums array
For Each vData In aData
If Len(vData) > 0 And IsNumeric(vData) Then
ixNum = ixNum + 1
aNums(ixNum) = vData
End If
Next vData
End With
lMaxRows = Application.Max(wsDest.Range("C9:O9"))
If lMaxRows = 0 Then Exit Sub 'Row count not populated in row 9 for each column
ReDim aResults(1 To WorksheetFunction.Max(wsDest.Range("C9:O9")), 1 To 13)
'Populate each column accordingly and pull a random number from aNums
For ixCol = 1 To UBound(aResults, 2)
If IsNumeric(wsDest.Cells(9, ixCol + 2).Value) Then
For ixResult = 1 To CLng(wsDest.Cells(9, ixCol + 2).Value)
Randomize
aResults(ixResult, ixCol) = aNums(Int(Rnd() * lNumCount) + 1)
Next ixResult
End If
Next ixCol
wsDest.Range("C13").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub

VBA loop omitted while executing through F5, but executes on step by step execution using F8

I have some values (derived out of a formula) in a particular row in an excel sheet. I am trying to drag them down till a certain number of rows using .FillDown method of Range looping through all the columns.
Sub RawDataPreparation()
Dim v As Long
Dim LastRow As Long
Dim lastCol As Integer
Dim c As Integer
c = ThisWorkbook.Sheets("Metadata").Range("B10")
Dim ColName() As String
ReDim ColName(c)
Dim strFormulas() As Variant
ReDim strFormulas(c)
Dim lastColumn As Integer
With ThisWorkbook.Sheets("Raw Data")
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
For i = 0 To c - 1
On Error Resume Next
ColName(i) = ThisWorkbook.Sheets("Metadata").Range("C" & i + 10) 'copy the value corresponding to column C10:C18 in Metadata sheet to the array
ThisWorkbook.Sheets("Raw Data").Cells(1, lastColumn + 1 + i).Value = ColName(i)
Next i
With ThisWorkbook.Sheets("Raw Data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For j = 0 To c - 1
On Error Resume Next
strFormulas(j) = ThisWorkbook.Sheets("Metadata").Range("D" & j + 10) 'copy the formulas corresponding to column D10:D18 in Metadata sheet to the array
With ThisWorkbook.Sheets("Raw Data")
.Cells(2, lastColumn + 1 + j).Formula = strFormulas(j)
End With
Next j
'Code to drag down the formula till last row.
For k = 0 To c - 1
ThisWorkbook.Sheets("Raw Data").Range(Cells(2, lastColumn + 1 + k), Cells(LastRow, lastColumn + 1 + k)).FillDown
Next k
End Sub
When I execute using F8 (step by step) the last loop (to drag the formula till last row) is being executed and giving intended result. But upon executing the entire Sub RawDataPreparation using F5, the last loop is getting omitted.
I am not able to understand this behavior. Can anyone suggest why this is happening?
You need to qualify references to Cells, Range, Rows, etc unless you KNOW that your ActiveSheet is the sheet being referred to.
So change your last statement to
ThisWorkbook.Sheets("Raw Data").Range(ThisWorkbook.Sheets("Raw Data").Cells(2, lastColumn + 1 + k), ThisWorkbook.Sheets("Raw Data").Cells(LastRow, lastColumn + 1 + k)).FillDown
Or, to make it a bit easier to read:
With ThisWorkbook.Sheets("Raw Data")
.Range(.Cells(2, lastColumn + 1 + k), .Cells(LastRow, lastColumn + 1 + k)).FillDown
End With
In order to make your code work the last loop should define the range somewhat like this:-
Dim k As Long
For k = 0 To C - 1
With ThisWorkbook.Sheets("Raw Data")
.Range(.Cells(2, lastColumn + 1 + k), .Cells(lastRow, lastColumn + 1 + k)).FillDown
End With
Next k
Observe the period before the Cells defining the range. This period makes the references refer to the "Raw Data" sheet, whereas in your code, in the absence of any spacification, they refer to the ActiveSheet. So you get a different result not depending upon how you trigger the code but which is the active sheet at the time.
Anyway, to prove my point I had to almost rewrite your code. I continued to finish the job, and here it is.
Sub RawDataPreparation()
' 24 Mar 2017
Dim WsMetadata As Worksheet
Dim WsRawData As Worksheet
Dim firstMetaRow As Long, TransferRow As Long
Dim nextCol As Integer
Dim lastRow As Long
Dim R As Long, C As Long
firstMetaRow = 10 ' set this value here instead of in the code
Set WsMetadata = ThisWorkbook.Sheets("Metadata")
TransferRow = CLng(Val(WsMetadata.Range("B10").Value)) - 1
' B10 can't have a value < 1. In your example it should be 9
If TransferRow < 0 Then Exit Sub
Set WsRawData = ThisWorkbook.Sheets("Raw Data")
With WsRawData
nextCol = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
End With
' transpose columns C and D of WsMetaData to rows 1 and 2 in WsRawData
For R = firstMetaRow To (firstMetaRow + TransferRow)
With WsMetadata
.Cells(R, "C").Copy Destination:=WsRawData.Cells(1, (nextCol + R - firstMetaRow))
.Cells(R, "D").Copy Destination:=WsRawData.Cells(2, (nextCol + R - firstMetaRow))
End With
Next R
With WsRawData
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(.Cells(2, nextCol), .Cells(lastRow, nextCol + TransferRow)).FillDown
End With
End Sub
It works, but unfortunately it may not do the job you envisioned. The formulas you copy from the Metadata contain references to that sheet which can't be translated 1:1 once the range is transposed. You may have to settle for pasting values or translate the formulas before filling them down.

Resources