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

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.

Related

Loop through column that has blanks - excel

I want to know how to loop this a column that blanks inside the column.
I am trying to run a script where if there is a group of a data together, it will make a new column. I got it from here: https://stackoverflow.com/a/15418263/15730901
The problem is that only works for the first column, if I try it a second time on a different column it will stop at the blank because of the loop condition. Is there anyway to change the loop condition to check for the whole column instead of stopping on a blank cell?
Code
sub AddBlankRows()
'
dim iRow as integer, iCol as integer
dim oRng as range
set oRng=range("a1")
irow=oRng.row
icol=oRng.column
do
'
if cells(irow+1, iCol)<>cells(irow,iCol) then
cells(irow+1,iCol).entirerow.insert shift:=xldown
irow=irow+2
else
irow=irow+1
end if
'
loop while not cells (irow,iCol).text=""
'
end sub
Thank you for your time,
Use Range.Find to find the last non-blank cell in the column
lastRow = Columns(iCol).Find("*", SearchOrder:=xlByRows, SearchDirections:=xlPrevious).Row
The your loop becomes
for iRow = lastRow - 1 to firstRow Step -1
if cells(irow + 1, iCol) <> cells(irow,iCol) then
cells(irow + 1,iCol).entirerow.insert shift:=xldown
end if
next iRow
Inserting a Row After a Group of Data
Here's a link to an answer that I posted where the OP was using the same code but wanted it to work for multiple columns. The question has been deleted by the author, so you may not have enough reputation to see it.
A Quick Fix
Option Explicit
Sub AddBlankRows()
Dim rg As Range: Set rg = Range("A1")
Dim r As Long: r = rg.Row
Dim c As Long: c = rg.Column
Dim lRow As Long: lRow = Range("A" & Rows.Count).End(xlUp).Row
Do Until r > lRow
If Len(Cells(r + 1, c).Value) > 0 And Len(Cells(r, c).Value) > 0 _
And Cells(r + 1, c).Value <> Cells(r, c).Value Then
Cells(r + 1, c).EntireRow.Insert Shift:=xlDown
r = r + 2
Else
r = r + 1
End If
Loop
'
End Sub

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

Cell value will not compare to a Variant array value

I am having an issue getting array values to compare to values stored in cells on the spreadsheet.
I have tried having the cell value compare directly to the array value, but the check fails every time.
To attempt to correct this issue I have tried assigning the cell value on each iteration to a variable dimmed as varient (Just as the array is dimmed a varient)
Values are added to the array successfully and the varient type is used as some invoices are numbers only while others include letters.
When I walk through my code the variable is not being assigned/accepting a value. Every time the comparison statement is reached the variable shows that it is empty.
Dim Paidlrow As Long
Dim lrow As Long
Dim wb As Workbook
Dim Consolid As Worksheet
Dim PaidInv As Worksheet
Dim Summary As Worksheet
Dim Invoices() As Variant
Dim InvCheck As Variant
Dim txt As String
Dim Formula As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim Cleared As Long
Dim LInv As Long
Dim NewBlank As Long
Dim MaxSheets As Integer
Set wb = Workbooks("Wire Payments projections for Euro's")
Set Consolid = wb.Sheets("Consolidation")
Set Summary = wb.Sheets("Pay Summary")
Set PaidInv = wb.Sheets("Paid Invoices")
'define define and define
MaxSheets = wb.Sheets.Count
lrow = Consolid.Cells(Rows.Count, 1).End(xlUp).Row + 1
Cleared = 1
ReDim Preserve Invoices(1 To Cleared)
i = 2
With wb
'begin inv extraction loop
For i = 2 To lrow
ReDim Preserve Invoices(1 To Cleared)
'if inv is marked for payment, add to array and move details to paid inv tab
With PaidInv
Paidlrow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End With
With Consolid
If .Cells(i, 10) = "X" Or .Cells(i, 10) = "x" Then
Invoices(Cleared) = .Cells(i, 1)
Consolid.Rows(i).Copy Destination:=PaidInv.Cells(Paidlrow, 1)
Consolid.Rows(i).Clear
Cleared = Cleared + 1
End If
End With
Next i
End With
'loop through each sheet to remove paid invoices identifie in previous loop
For k = 1 To MaxSheets
If wb.Sheets(k).Name <> Summary.Name And wb.Sheets(k).Name <> PaidInv.Name And wb.Sheets(k).Name <> Consolid.Name Then
With wb.Sheets(k)
LInv = Cells(Rows.Count, 2).End(xlUp).Row + 1
For j = LBound(Invoices) To UBound(Invoices)
For l = 7 To LInv
InvCheck = .Cells(l, 2).Value
If Invoices(j) = InvCheck And InvCheck <> "" Then
'.Rows(l).Delete
NewBlank = Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A7:K7").Copy
.Range(.Cells(NewBlank, 1), .Cells(NewBlank, 11)).PasteSpecial Paste:=xlPasteFormats
'.Cells(NewBlank, 1) = Right(.Cells(1, 9), 6)
'Formula = "=$B$3*I"
'Formula = Formula & NewBlank
'.Cells(NewBlank, 10).Formula = Formula
End If
Next l
Next j
End With
End If
Next k
I have commented out code for the ease of testing. With the way it is now it should format some additional cells to match the formatting above it.
UPDATE
For kicks and giggles, I changed the Array and associated variable check to String type rather than variant. For some reason, this fixed the issue I was having. I am so confused...
There seems to be a dot missing:
With wb.Sheets(k)
LInv = Cells(Rows.Count, 2).End(xlUp).Row + 1
should be:
With wb.Sheets(k)
LInv = .Cells(Rows.Count, 2).End(xlUp).Row + 1
to ensure that LInv is read from sheet number k.
As it is, the code is equivalent to:
With wb.Sheets(k)
LInv = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 1
and, if the active sheet doesn't have any values in the cells you are looking at, the comparison will fail.
There's a similar issue with this line later on in the code:
NewBlank = Cells(Rows.Count, 1).End(xlUp).Row + 1
should be:
NewBlank = .Cells(Rows.Count, 1).End(xlUp).Row + 1

Looping & If not working for the second instruction

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

Dynamically reformatting an excel sheet

I have a very messy excel sheet that I'm trying to reformat into something readable. Currently, it is structured as such (each large separation resembles a new cell):
Title1 Var1 Var1_Value Var1.1 Var1.1_Value ... Var1.K Var1.K_Value
Title2 Var2 Var2_Value Var2.1 Var2.1_Value ... Var2.L Var2.L_Value
...
TitleM VarM VarM_Value VarM.1 VarM.1_Value ... VarM.N VarM.N_Value
To clarify, the amount of variables and values per column varies for each row, however every variable will have a value. Ultimately, my end goal is to create something formatted as such:
Title1 Var1 Var1_Value
Title1 Var1.1 Var1.1_Value
...
TitleM VarM.N VarM.N_Value
Where the Title string is repeated for each Var and Var_Value in its row.
I don't know a lot about VBA, so I'm looking for help on the best avenue to achieve this formatting. Here is my thought process in psuedocode below, I tried to format to be VBA-esque when I could.
for idx = 1 To lastRow
' Will likely have to create a function to find
' last filled column in a row -- lastColForRow
tempArray = data(idx,2 To lastColforRow(idx))
for jdx = 1 To length(tempArray)-1 Step 2
newCell(end+1,1) = data(idx,1)
newCell(end+1,2) = tempArray(j)
newCell(end+1,3) = tempArray(j+1)
next jdx
next idx
This code should do it (note that it assumes that there is no header row)
Public Sub Reformat()
Dim lastrow As Long
Dim lastcol As Long
Dim numrows As Long
Dim i As Long, ii As Long
Application.ScreenUpdating = False
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lastrow To 1 Step -1
lastcol = .Cells(i, .Columns.Count).End(xlToLeft).Column
'integer division so as to get the number of value pairs
numrows = lastcol \ 2
'only do anything if we have more than one value pair
If numrows > 1 Then
'insert extra rows for extra value pairs
.Rows(i + 1).Resize(numrows - 1).Insert
'copy the titles down to all new rows
.Cells(i, "A").Copy .Cells(i, "A").Resize(numrows)
'a value pair at a time, cut and copy to next new row
For ii = 4 To lastcol Step 2
'target row is current row (i) + the value pair index ((ii /2)-1)
.Cells(i, ii).Resize(, 2).Cut .Cells(i + (ii / 2) - 1, "B")
Next ii
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
This does it with arrays onto a new sheet
Sub climatefreak()
Dim lastrow&
Dim ws As Worksheet
Dim lastcolumn&
Dim idx&
Dim ClmIdx&
Dim tws As Worksheet
Dim i&
Dim trw&
Set tws = Sheets("Sheet3")
Set ws = ActiveSheet
With ws
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For idx = 1 To lastrow
Dim temparr
lastcolumn = .Cells(idx, .Columns.Count).End(xlToLeft).Column
temparr = Range(.Cells(idx, 1), .Cells(idx, lastcolumn)).Value
For i = LBound(temparr, 2) + 1 To UBound(temparr, 2) Step 2
trw = tws.Range("A" & tws.Rows.Count).End(xlUp).Row + 1
tws.Cells(trw, 1) = temparr(UBound(temparr, 1), 1)
tws.Cells(trw, 2).Resize(, 2) = Array(temparr(1, i), temparr(1, i + 1))
Next i
Next idx
End With
End Sub

Resources