So I'm trying to compare dates in the chart pictured. I want to compare cells 1 and 2 and if the dates are the same then move to 3 and 4 and do the same comparison and then move to 5 and 6 and so on. If the dates are different I want to add 1 to a counter. Then at the end of each row I need to fill the cell at the end of the row with the 0 in it currently with the counter value and then reset the counter and move to the next row and so on. so the circled counter should read 1 because there is one pair of different dates. The code i have so far is attached. Currently it tells me "Object required" at Set CompD1. Pretty new to this so any help is appreciated.
Dim i As Integer
Dim j As Integer
Dim AdjPln As Integer
Dim CompD1 As Range
Dim CompD2 As Range
Dim cRow As Integer
For i = 0 To 49
AdjPln = 0
cRow = i + 13
For j = 0 To 9
Set CompD1 = Cells(cRow, j + 5).value
Set CompD2 = Cells(cRow, j + 6).value
If CompD1 = CompD2 Then
j = j + 2
Else
AdjPln = AdjPln + 1
j = j + 2
End If
Next j
Cells(cRow, 24) = AdjPln
Stop
Next i
I think your j loop is the issue when you tried to change the value with the formula to increment by 2 instead of 1. When you went to loop by increments other than one, you can use the Step option. In your case, you want to loop j by 2 so Step 2. You can also do negative if that is useful.
See if this works:
Dim i As Integer, j As Integer, AdjPln As Integer, cRow As Integer
For i = 0 To 49
AdjPln = 0
cRow = i + 13
For j = 0 To 9 Step 2
If Cells(cRow, j + 5).Value <> Cells(cRow, j + 6).Value Then
AdjPln = AdjPln + 1
End If
Next j
Cells(cRow, 24) = AdjPln
Next i
It appears that this could be done with a simple formula. Put this in X13 and drag down.
=SUMPRODUCT((E13:U13<>F13:V13)*(E13:U13<>"")*(F13:V13<>"")*ISODD(COLUMN(E13:U13)))
Related
I have a question regarding finding and detecting gaps per row in VBA excel.
The dificult part is gaps that start on Friday and run until Thursday (FTGaps) need to be added up seperately and gaps starting on other days have to be counted seperately.
So for instance in the picture the result from the first row has to be: 1 FTGap and 1 Gap
And the second row has to be 1 FTGap.
But if there is a empty cell earlier in the row it has to be counted as a different gap.
So for instance the following rows output is 2 gaps and 1 FTGap.
I hope my question is clear.
Thanks in advance
What I tried
For Row = 3 To Worksheets("Kalender2").UsedRange.Rows.Count
GapDays = 0
FTGapDays = 0
For col = 2 To 55 'Worksheets("Kalender2").Cells(2,
Columns.Count).End(xlToLeft).Column
If Worksheets("Kalender2").Cells(Row, col) = "0" And
Worksheets("Kalender2").Cells(2, col).Value = "Friday" Then
FTGapDays = FTGapDays + 1
ElseIf Worksheets("Kalender2").Cells(Row, col) = "0" And
FTGapDays <> 0 Then
FTGapDays = FTGapDays + 1 'doortellen gap startend op
vrijdag
ElseIf Worksheets("Kalender2").Cells(Row, col) = "0" And
FTGapDays = 0 Then 'And Worksheets("Kalender2").Cells(2, Col).Value <>
"Friday" Then
GapDays = GapDays + 1 'eerste lege cel andere dag dan
vrijdag
End If
Next col
If col = 54 Then
Call EndGap
End If
Call EndGap
Next Row
'
And then the second Sub Endgap():
If FTGapDays <> 0 Then
If FTGapDays < 7 Then
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 7 And FTGapDays < 14 Then
FTGaps = FTGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 14 And FTGapDays < 21 Then
FTGaps = FTGaps + 2
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 21 And FTGapDays < 28 Then
FTGaps = FTGaps + 3
LegGaps = LegGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 28 And FTGapDays < 35 Then
FTGaps = FTGaps + 4
LegGaps = LegGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays >= 35 And FTGapDay < 42 Then
FTGaps = FTGaps + 5
LegGaps = LegGaps + 1
If GapDays = 0 Then
Gaps = Gaps + 1
End If
ElseIf FTGapDays = 42 Then
FTGaps = FTGaps + 6
LegGaps = LegGaps + 2
End If
End If
End Sub
Please, test the next solution. It uses a kind of trick: Dividing a number to 0 in a formula will return an error. So, such a formula is placed two rows down after the last, then using SpecialCells(xlCellTypeFormulas, xlErrors) creates a discontinuous range of the gaps and process it. The processing result is returned two columns to the right of the last column. In the first such a column the 'Gaps' and in the second one 'FTGap'. The code assumes that the row keeping the days name is the second and the zero (0) seen in your pictures are values not string as you tried using in your code:
Sub extractGaps()
Dim sh As Worksheet, lastR As Long, lastCol As Long, rng As Range, arrCount, arrRows, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
If sh.Range("A" & lastR).HasFormula Then
If left(sh.Range("A" & lastR).Formula, 3) = "=1/" Then
sh.rows(lastR).EntireRow.ClearContents
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
End If
End If
lastCol = sh.cells(2, sh.Columns.count).End(xlToLeft).column
ReDim arrCount(1 To lastR - 2, 1 To lastCol)
Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False
For i = 3 To lastR
arrRows = countGaps(sh.Range("A" & i, sh.cells(i, lastCol)), lastR, lastCol)
arrCount(i - 2, 1) = arrRows(0): arrCount(i - 2, 2) = arrRows(1)
Next i
sh.Range("A" & lastR + 2).EntireRow.ClearContents
sh.cells(3, lastCol + 2).Resize(UBound(arrCount), 2).value = arrCount
Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Function countGaps(rngR As Range, lastR As Long, lastCol As Long) As Variant
Dim sh As Worksheet: Set sh = rngR.Parent
Dim rngProc As Range, i As Long, A As Range, FTGap As Long, Gap As Long
Dim boolGap As Boolean, bigGaps As Double, mtchFr
Set rngProc = sh.Range(sh.cells(lastR + 2, 1), sh.cells(lastR + 2, lastCol)) 'a range where to place a formula returnig errors deviding by 0...
rngProc.Formula = "=1/" & rngR.Address
On Error Resume Next
Set rngProc = rngProc.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If rngProc.cells.count = rngR.cells.count Then
If IsNumeric(rngProc.cells(1)) Then countGaps = Array(0, 0): Exit Function
End If
If rngProc Is Nothing Then countGaps = Array(0, 0): Exit Function 'in case of no gaps...
Gap = 0: FTGap = 0: Debug.Print rngProc.Areas.count
For Each A In rngProc.Areas
Debug.Print sh.Range(sh.cells(2, A.cells(1).column), sh.cells(2, A.cells(A.Columns.count).column)).Address: 'Stop
If A.cells.count < 7 Then
Gap = Gap + 1
ElseIf A.cells.count = 7 Then
If sh.cells(2, A.cells(1).column).value = "Friday" Then
FTGap = FTGap + 1
Else
Gap = Gap + 1
End If
Else 'for more than 7 empty cells:
'set the Friday day position in the empty cells range/area:
mtchFr = Application.match("Friday", sh.Range(sh.cells(2, A.cells(1).column), sh.cells(2, A.cells(A.Columns.count).column)), 0)
If A.Columns.count - mtchFr < 6 Then 'no any FTGap existing:
Gap = Gap + 1
ElseIf A.cells.count - mtchFr = 6 Then 'fix a FTGap
Gap = Gap + 1: FTGap = FTGap + 1
Else
bigGaps = ((A.cells.count - mtchFr) - i + 1) / 7
FTGap = FTGap + Int(bigGaps)
If mtchFr <> 1 Then Gap = Gap + 1 'the gap before Friday
If A.cells.count - i + 1 - Int(bigGaps) * 7 > 0 Then Gap = Gap + 1
End If
End If
Next A
countGaps = Array(Gap, FTGap)
End Function
Problem
We have a range (apparently "B3:BC" & UsedRange.Rows.count). The range is preceded by a row (B2:BC2) containing days of the week repeated in consecutively order: Monday, Tuesday, etc.
Cells for each row in the range contain either a 0 or some other value (integer? does not matter much). Consecutive 0's in a row (length > 0) are treated as a gap. We have two types of gaps:
a regular Gap: a range of consecutive 0's of any length > 0;
a Friday-through-to-Thursday-Gap (FtGap): a range of consecutive 0's, that starts on a Friday and ends on Thursday (length = 7).
For each row we want to count the number of Gaps and FtGaps, taking into account the following condition: a range of consecutive 0's that qualifies as a FtGap should not also be counted as a regular Gap.
Solution
To solve this problem, I've used range B3:BC20 for the data. Cells in this range have been populated randomly with either 0's or 1's (but this value could be anything) using =IF(RAND()>0.8,0,1). My row with "days of the week" starts with a "Monday", but this should make no difference.
I've used the following method:
Create two arrays for row days and the data.
Loop through each row array with nested loop through cols to access all cells per row.
On each new 0, increment the total Gap count (GapTrack) by 1. For each new 0, increment a variable (GapTemp) by 1 that tracks the length of the Gap. Reset GapTemp on the next non-0.
For each 0 on a "Friday", start incrementing a variable FtTemp. We keep checking if its value (length) has reached any multiple of 7. When it does, we increment the Ft count (FtTrack) by 1.
On each new non-0, check if FtTemp mod 7 = 0 and GapTemp Mod 7 = 0 and GapTemp > 0. If True, we will have added a regular Gap to our total count of the same length as one or more FtTemps. This violates the condition mentioned above. Remedy this by decrementing GapTrack by 1.
At the end of the row, we wrap GapTrack and FtTrack inside an array, assign it to a new key in a dictionary. At the start of the next row, we reset all our variables, and restart the count.
When the loop is finished, we end up with a dictionary that contains all our counts per row. We write this data away somewhere.
Code as follows with some further notes on what is happening. N.B. I've used "Option Explicit" to force proper declaration of all our variables.
Option Explicit
Sub CountGaps()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Kalender2")
Dim rngDays As Range, rngData As Range
Dim arrDays As Variant, arrData() As Variant
Set rngDays = ws.Range("Days") 'Named range referencing $B$2:$BC$2 in "Kalender2!"
Set rngData = ws.Range("Data") 'Named range referencing $B$3:$BC$20 in "Kalender2!"
'populate arrays with range values
arrDays = rngDays.Value 'dimensions: arrDays(1, 1) to arrDays(1, rngDays.Columns.Count)
arrData = rngData.Value 'dimensions: arrData(1, 1) to arrData(rngData.rows.Count, rngData.Columns.Count)
'declare ints for loop through rows (i) and cols (i) of arrData
Dim i As Integer, j As Integer
'declare booleans to track if we are inside a Gap / FtGap
Dim GapFlag As Boolean, FtFlag As Boolean
'declare ints to track current Gap count (GapTemp), sum Gap count (GapTrack), and same for Ft
Dim GapTemp As Integer, GapTrack As Integer, FtTemp As Integer, FtTrack As Integer
'declare dictionary to store GapTrack and FtTrack for each row
'N.B. in VBA editor (Alt + F11) go to Tools -> References, add "Microsoft Scripting Runtime" for this to work
Dim dict As New Scripting.Dictionary
'declare int (counter) for iteration over range to fill with results
Dim counter As Integer
'declare key for loop through dict
Dim key As Variant
'-----
'start procedure: looping through arrData rows: (arrData(i,1))
For i = LBound(arrData, 1) To UBound(arrData, 1)
'for each new row, reset variables to 0/False
GapTemp = 0
GapTrack = 0
GapFlag = False
FtTemp = 0
FtTrack = 0
FtFlag = False
'nested loop through arrData columns: (arrData(i,2))
For j = LBound(arrData, 2) To UBound(arrData, 2)
If arrData(i, j) = 0 Then
'cell contains 0: do stuff
If arrDays(1, j) = "Friday" Then
'Day = "Friday", start checking length Ft gap
FtFlag = True
End If
'increment Gap count
GapTemp = GapTemp + 1
If GapFlag = False Then
'False: Gap was not yet added to Total Gap count;
'do this now
GapTrack = GapTrack + 1
'toggle Flag to ensure continuance of 0 range will not be processed anew
GapFlag = True
End If
If FtFlag Then
'We are inside a 0 range that had a Friday in the preceding cells
'increment Ft count
FtTemp = FtTemp + 1
If FtTemp Mod 7 = 0 Then
'if True, we will have found a new Ft Gap, add to Total Ft count
FtTrack = FtTrack + 1
'toggle Flag to reset search for new Ft Gap
FtFlag = False
End If
End If
Else
'cell contains 1: evaluate variables
If (FtTemp Mod 7 = 0 And GapTemp Mod 7 = 0) And GapTemp > 0 Then
'if True, then it turns out that our last range STARTED with a "Friday" and continued through to a "Thursday"
'if so, we only want to add this gap to the Total Ft count, NOT to the Total Gap count
'N.B. since, in fact, we will already have added this range to the Total Gap count, we need to retract that step
'Hence: we decrement Total Gap count
GapTrack = GapTrack - 1
End If
'since cell contains 1, we need to reset our variables again (except of course the totals)
GapTemp = 0
GapFlag = False
FtTemp = 0
FtFlag = False
End If
Next j
'finally, at the end of each row, we assign the Total Gap / Ft counts as an array to a new key (i = row) in our dictionary
dict.Add i, Array(GapTrack, FtTrack)
Next i
'we have all our data now stored in the dictionary
'example of how we might write this data away in a range:
rngDays.Columns(rngData.Columns.Count).Offset(0, 1) = "Gaps" 'first col to the right of data
rngDays.Columns(rngData.Columns.Count).Offset(0, 2) = "FtGaps" 'second col to the right of data
'set counter for loop through keys
counter = 0
For Each key In dict.Keys
'resize each cell in first col to right of data to fit "Array(GapTrack, FtTrack)" and assign that array to its value ("dict(key)")
rngData.Columns(rngData.Columns.Count).Offset(counter, 1).Resize(1, 2).Value = dict(key)
'increment counter for next cell
counter = counter + 1
Next key
End Sub
Snippet of result:
Let me know if you experience any difficulties with implemention.
I have the values on the range "A1:O1".
Each Column has a unique value in this range.
I need help to develop a loop that will fill down 04 times on each column the same Top Value (Column Value). Below a Pseudo Code
Sub FillDownRowsRandomly()
Dim i As Integer, j As Integer
'RamdomRow=Total of 04 unique ramdom numbers
'choosen from 01 to 06 {1,2,3,4,5,6}
'meaning that in a loop of 6 interations, when fill down
'2 will be Null or empty
'
For i = 1 To 15 'Columns "A" To "O"
For j = 2 To 7 '
'
Cells(RandomRow, i).Value = Cells(1, i).Value
Next j
Next i
End Sub
Below an Image where will be possible identify the result of the code.
Disregard the "Null" word written in the cells. I wrote that just to clarify that during the random loop, the code "ignored that cell".
Maybe something like:
Sub FillDownRowsRandomly()
Dim x As Long, y As Long, z As Long
With Sheet1 'Change accordingly
For y = 1 To 15
z = 0
Do While z < 4
x = Int((7 - 2 + 1) * Rnd + 2)
If .Cells(x, y) <> .Cells(1, y) Then
.Cells(x, y) = .Cells(1, y)
z = z + 1
End If
Loop
Next y
End With
End Sub
Loop the columns and randomly place the values till there are four in the six rows.
Sub FillDownRowsRandomly()
ActiveSheet.Range("A2:O7").ClearContents
Dim i As Long
For i = 1 To 15 'iterate the columns
Do Until Application.CountIf(ActiveSheet.Cells(2, i).Resize(6), ActiveSheet.Cells(1, i).Value) >= 4
Dim j As Long
j = Application.RandBetween(2, 7)
ActiveSheet.Cells(j, i).Value = ActiveSheet.Cells(1, i).Value
Loop
Next i
End Sub
I have challenges in highlighting/copying alternate rows in one column and pasting it to the next column and aligned.
Here's a screenshot:
Following code assumes you have two separate tabs, SRC and DST and the range of data starts in the first cell. Will do all in a single step:
Public Sub CopyAlternate()
Dim i As Long
i = 2
While Len(Sheets("SRC").Cells(i, 1).Value) > 0
Sheets("DST").Cells(i / 2 + 1, 1).Value = Sheets("SRC").Cells(i, 1).Value
Sheets("DST").Cells(i / 2 + 1, 2).Value = Sheets("SRC").Cells(i + 1, 1).Value
i = i + 2
Wend
End Sub
You can take this code and adjust it to taste:
Sub alternate()
Dim i As Integer
Dim j As Integer
Dim n As Integer
i = 0
j = 0
n = 0
With ActiveSheet
For Each c In .Range("A4:A16")
.Cells(20 + j, 1 + i).Value = c.Value
If n = 0 Or n Mod 2 = 0 Then
i = 1
j = j
Else
i = 0
j = j + 1
End If
n = n + 1
Next c
End With
End Sub
This worked for me when rebuilding your example with letters (for faster checking).
I am new to Excel VBA and I want to calculate the distance between two atoms and make a loop to calculate it for all wanted cases
with coordinate B(i), C(i), D(i) in the Excel sheet correspond to x,y,z cartesian coordinate..
these atoms are located : One in a row (i) and the other in a row (i+5)
I write this algorithm but I cant transfer it to excel VBA
For i=4 to 1000
For j=9 to 1000
d=SQRT(POWER(B(i)-B(j),2)+ POWER(C(i)-C(j),2)+ POWER(D(i)-D(j),2))
print **d** in (P(i)) #want to print the distance **d** in a case
j=j+4 # **j** is a multiple of 4
i=i+4 # **i** is a multiple of 4
next i
Thanks, this is my first question
I think that the following should work for you:
Sub FindDistances()
Dim i As Long, j As Long
Dim r As Long, c As Long 'row and column indices for output
Dim data As Variant
Application.ScreenUpdating = False 'useful when doing a lot of writing
data = Range("B4:D1000").Value 'data is a 1-based array
c = 5 'column E
For i = 1 To UBound(data) - 5 Step 4
r = 1 'first row printed in -- adjust if need be
For j = i + 5 To UBound(data) Step 4
Cells(r, c).Value = Sqr((data(i, 1) - data(j, 1)) ^ 2 + (data(i, 2) - data(j, 2)) ^ 2 + (data(i, 3) - data(j, 3)) ^ 2)
r = r + 1
Next j
c = c + 1
Next i
Application.ScreenUpdating = True
End Sub
Something like this? In VBA, you refer to cells like Cells(row, column). Data is supposed to be located in a worksheet named Sheet1. I'm calculating each dimension separately (d1, d2, d3) just for reading simplicity. You can merge those four lines in one if you like. EDIT: reading your comments above, I add a nested loop (j).
Sub Distances()
Dim i As Integer
Dim j As Integer
Dim d1 As Double, d2 As Double, d3 As Double, d As Double
For i = 4 To 1000 Step 4 'Can't understand your data, but Step 4 tries to account for your j=j+4 and i=i+4
For j = 9 To 1000 Step 4
d1 = (Worksheets("Sheet1").Cells(i, 2) - Worksheets("Sheet1").Cells(j, 2)) ^ 2
d2 = (Worksheets("Sheet1").Cells(i, 3) - Worksheets("Sheet1").Cells(j, 3)) ^ 2
d3 = (Worksheets("Sheet1").Cells(i, 4) - Worksheets("Sheet1").Cells(j, 4)) ^ 2
d = Sqr(d1 + d2 + d3)
Worksheets("Sheet1").Cells(i, 16).Value = d
Next j
Next i
End Sub
Option Explicit
Sub AtomDistance()
'
' AtomDistance Macro1
'
'
Dim i As Integer
Dim j As Integer
Dim Distance As Double
Dim Column As String
Column = InputBox("Which column you want to print results(put a letter)?")
Dim MyCell11 As String
Dim MyCell12 As String
Dim MyCell13 As String
Dim MyCell21 As String
Dim MyCell22 As String
Dim MyCell23 As String
Dim MyCell3 As String
j = 9
For i = 4 To 12
MyCell3 = Column & i
MyCell11 = "B" & i
MyCell12 = "C" & i
MyCell13 = "D" & i
MyCell21 = "B" & j
MyCell22 = "C" & j
MyCell23 = "D" & j
Distance = (((Range(MyCell11).Value - Range(MyCell21).Value) ^ 2) + ((Range(MyCell12).Value - Range(MyCell22).Value) ^ 2) + ((Range(MyCell13).Value - Range(MyCell23).Value) ^ 2)) ^ 0.5
If i Mod 4 = 0 Or j Mod 4 = 0 Then
Range(MyCell3).Value = Distance
End If
j = j + 1
Next i
I keep getting error '483': Object doesn't support this property or method on he highlighted line. I'm a complete beginner with excel-vba and I am trying to learn it by myself.
Sub Magic()
Dim i As Integer, j As Integer, k As Integer
Dim featcode(9999)
Dim partnum(9999)
k = 4
i = 0
j = 0
For i = 2 To 616
featcode(i) = Cells(i, 1).Value
Next i
For j = 1 To 9999
partnum(j) = ThisWorkbook.Worksheets(3).Cells(j, 8).Value
Next j
For i = 2 To 616
For j = 1 To 1000
If featcode(i) = partnum(j) Then
**ThisWorkbook.Worksheets(2).Cells(i, k).Value = ThisWorkbook.Worksheets(3).partnum(j).Value**
k = k + 1
End If
Next j
k = 4
Next i
End Sub
This isn't exclusively an answer to your question, I wanted to als give you some tips regarding your code
Sub Magic()
Dim ws as Worksheet
Dim i As Integer, j As Integer, k As Integer
'You can use dynamic arrays in VBA so you dont have to "guess" the length beforehand, see first comment to this answer
Dim featcode(9999)
Dim partnum(9999)
Set ws = ThisWorkbook.Worksheets(3)
'you dont have to assign values to these variables outside of your for loop, as you assign them right there
k = 4
i = 0
j = 0
For i = 2 To 616
featcode(i) = Cells(i, 1).Value
Next i
'indent new lines properly, so you don't lose overview
For j = 1 To 9999
partnum(j) = ThisWorkbook.Worksheets(3).Cells(j, 8).Value
Next j
For i = 2 To 616
For j = 1 To 1000
If featcode(i) = partnum(j) Then
'you can declare objects for referencing to worksheets or cells, so you dont have to write these enormous blocks of code (see above)
'so instead of ThisWorkbook.Worksheets(2).Cells(i, k).Value = partnum(j)
'use
ws.Cells(i,k) = partnum(j)
k = k + 1
End If
Next
k = 4
Next
End Sub
HTH :)