I am trying to calculate some values from specific columns in Sheet1 and Sheet2. The problem is that the Sub below first correctly calculates the numbers from a matrix in Sheet1. It puts the matrix in some cells on Sheet1. And then the code rewrites that matrix with the numbers from Sheet2. But I want to put the calculations from Sheet2 on Sheet2, not Sheet1. Any ideas about what I am doing wrong? Best Regards!
Sub Try()
Dim LastRow As Long
Dim LastOne As Long
Dim Sheetz As Variant
Sheetz = Array("Sheet1", "Sheet2")
For h = LBound(Sheetz) To UBound(Sheetz)
With Worksheets(Sheetz(h))
numbers = Array(1, 2, 3)
For j = LBound(numbers) To UBound(numbers)
For i = 1 To 3
LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
LastValue = .Cells(.Rows.Count, i).End(xlUp).Value
FirstOne = .Cells(LastRow - j, i).Value
Cells(i + 1, j + 5) = LastValue / FirstOne - 1
Next i
Next j
End With
Next h
End Sub
Related
The goal is to compare for two matches on two columns between two similarly formatted sheets for a matching row. Once matched, we would sort through each column of the matched rows and replace data from sht3 onto sht2 to add updated info.
I have considered using dictionary objects for the matching but haven't figured it out, you can see that by trying to match two columns between two sheets, this gets very time consuming when there are (possibly tens of) thousands of rows.
Is there an alternative to dictionaries , if not then how would I bets implement them?
I'm not sure if the following function is relevant but thought I'd include the whole picture.
Private Sub update_tracking(sht2 As Worksheet, sht3 As Worksheet, refsht As Worksheet)
Dim excludearr As Variant, termarr() As Variant
Dim sht2count As Long, i As Long, x As Long
Dim sht2rng As Range, cell As Range, pool As Range
'need to find a more efficient way of this
' for sht3sht, i is rows and j is columns
sht2count = Application.CountA(sht2.Range("A:A"))
Set sht2rng = sht2.Range("A2:A" & sht2count)
i = 2
Do While i <= sht2count
For Each cell In sht2rng
If cell.Value = sht3.Cells(i, 1) And cell.Offset(0, 2).Value = sht3.Cells(i, 3) Then
'call update function
Update_cells cell, sht3, i
sht3.Cells(i, 1).EntireRow.Delete
i = i - 1
End If
Next
i = i + 1
Loop
Function Update_cells(cell As Range, sht3 As Worksheet, i As Long)
Dim excludearr As Variant, j As Long
j = 1
'Add column max range
Do While j <= 35
'Adds exclusion columns
excludearr = Array(1, 3, 12, 26, 29)
If Not IsNumeric(Application.Match(j, excludearr, 0)) Then
If sht3.Cells(i, j) <> "" And sht3.Cells(i, j) <> cell.Offset(0, (j - 1)) Then
sht3.Cells(i, j).Copy
cell.Offset(0, (j - 1)).PasteSpecial Paste:=xlPasteAll
cell.Offset(0, (j - 1)).Interior.Color = vbYellow
End If
End If
j = j + 1
Loop
End Function
I have a table with information in column A and an appropriate value in column B. I want to write a macro that inserts a new row for each "Person" in dependence of the value in column B and copies the original information into that row, which for example means that in the end there are 5 rows with "Person A", 2 rows for "Person B" etc.
original table:
result:
My first approach looks like that. It doesn't work.
Dim i, j, k As Integer
For i = Range("A" & Range("A:A").Rows.Count).End(xlUp).Row To 1 Step -1
For j = 1 To Range("B" & i)
Rows(i).Select
Selection.Insert Shift:=xlDown
k = k + j
Range(Cells(k, 1), Cells(k, 2)).Copy Destination:=Range("A" & i)
Next j
Next i
This would work for you, changing the number of inserts based on value in column B:
Option Explicit
Sub test()
With Sheets(1)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = lastRow To 1 Step -1
If IsNumeric(.Cells(i, 2).Value) = True Then
Dim numberOfInserts As Long
numberOfInserts = .Cells(i, 2).Value - 1
If numberOfInserts > 0 Then
Dim insertCount As Long
For insertCount = 1 To numberOfInserts
.Rows(i).Copy
.Rows(i).Insert
Next insertCount
End If
End If
Next i
End With
End Sub
First we check that you're dealing with numbers. Second you have a single line already, so number -1, then that this number is >0. Lastly, you insert via a loop which does the counting for you.
Test data:
Output after running:
Your index calculation is messed up. Use the debugger, step thru the code (F8) and notice what happens:
a) Your Select/Insert-construct creates a new row above the row you want to copy, not below.
b) Your calculation of index k fails: You are not initializing k, so it starts with value 0. Than you add j (1..3) to k, resulting in values 1, 3, 6, and copy data from that line.
I would suggest you take a different approach: Copy the original data into an array and then loop over that array. This avoids multiple Select, Copy and Insert statements (that are slow) and allow to copy the data from top to bottom.
Sub copy()
Dim rowCount As Long
Dim data As Variant
With ActiveSheet ' Replace with the sheet you want to work with
' Copy the current table into array
rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
data = .Range(.Cells(1, 1), .Cells(rowCount, 2))
Dim oldRow As Long, newRow As Long
newRow = 1
' Loop over old data
For oldRow = 1 To rowCount
Dim repeatCount As Long
repeatCount = Val(data(oldRow, 2)) ' We want to have so many occurrences of the row
if repeatCount <= 0 Then repeatCount=1
Dim col As Long
' Create "repeatCount" rows of data (copy column by column)
For col = 1 To 2
.Cells(newRow, col).Resize(repeatCount, 1) = data(oldRow, col)
Next col
newRow = newRow + repeatCount
Next
End With
End Sub
I am trying to do a "for each" sub in VBA, comparing two pairs of rows and the values in each cell to one another. For example row 2 is compared with row 3, row 4 is compared with row 5 etc. I need the code to highlight the differences in each cell for each of the comparisons. This is what I have so far and I cannot seem to get it to work. Any thought?
Sub testing_2()
Dim rw_2 As Range, rw_1 As Range, decisions As String
decisions = MsgBox("Check accuracy?", vbYesNo)
If decisions = vbYes Then
For Each rw_1 In Worksheets("worksheet").Rows
For Each rw_2 In Worksheets("worksheet").Rows
If Not StrComp(rw_1.row Mod 2 = 0, rw_2.row Mod 2 = 1, vbBinaryCompare) = 0 Then
Range(rw_1.row Mod 2 = 0, rw_2.row Mod 2 = 1).Interior.ColorIndex = 6
End If
Next rw_2
Next rw_1
Else: End If
End Sub
Thank you!
Basically, I am looking at each row, two at a time, and highlighting the different values between them.
One loop to to loop the rows stepping 2 rows at a time and another loop to loop the columns
Sub testing_2()
decisions = MsgBox("Check accuracy?", vbYesNo)
If decisions = vbYes Then
With Worksheets("Sheet4") ' change to your sheet
Dim lstRw As Long
lstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim lstClm As Long
lstClm = .Cells(1, Columns.Count).End(xlToLeft).Column
Dim i As Long
For i = 2 To lstRw Step 2
Dim j As Long
For j = 2 To lstClm
If .Cells(i, j) <> .Cells(i + 1, j) Then
.Range(.Cells(i, j), .Cells(i + 1, j)).Interior.ColorIndex = 6
End If
Next j
Next i
End With
End If
End Sub
Gettin a "Type Mismatch" error.
Trying to take one matrix of numbers on one worksheet "Sheet1", divide by another matrix of numbers on a second worksheet "Sheet2", then show each cell result on a matrix on the third worksheet "Sheet1"
Sub MacroTest()
Worksheets("Sheet3").Range("C5") = Worksheets("Sheet1").Range("C5:DR124") / Worksheets("Sheet2").Range("C5:DR124")
End Sub
With this code you can do what you need on specific range (that you can choose) on different sheet and also on the same sheet.
Sub RangeDiv()
Dim RngFrom As Range
Dim RngDiv As Range
Dim RngTo As Range
Dim R As Integer
Dim C As Integer
Set RngFrom = Sheets(1).Range("A1:E3")
Set RngDiv = Sheets(1).Range("B6:F8")
Set RngTo = Sheets(1).Range("C10:G12")
'Check if all Rngs have the same number of rows and columns
If RngFrom.Rows.Count <> RngDiv.Rows.Count Or RngFrom.Rows.Count <> RngTo.Rows.Count Then
MsgBox ("Rngs rows number aren't equal")
Exit Sub
End If
If RngFrom.Columns.Count <> RngDiv.Columns.Count Or RngFrom.Columns.Count <> RngTo.Columns.Count Then
MsgBox ("Rngs columns number aren't equal")
Exit Sub
End If
For C = 1 To RngFrom.Columns.Count
For R = 1 To RngFrom.Rows.Count
'check cell value to avoid errors coming from dividing by 0
If Val(RngDiv.Cells(R, C)) <> 0 Then
RngTo.Cells(R, C) = RngFrom.Cells(R, C) / RngDiv.Cells(R, C)
Else
'Insert something when division is impossible
RngTo.Cells(R, C) = 0 'Or what you want to insert
End If
Next R
Next C
End Sub
I create sheet1 like this
Please click to see Image
then sheet2
Please click to see Image2
then create blank sheet 3
and use this code
Sub divideRange()
Dim lastRow, lastColumn As Long
lastColumn = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
lastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow
For j = 1 To lastColumn
Sheets("Sheet3").Cells(i, j).Value = Sheets("Sheet1").Cells(i, j).Value / Sheets("Sheet2").Cells(i, j).Value
Next j
Next i
End Sub
Is this what you want?
Sorry for my late reply.
You can solve your problem with a for-loop:
For i = 3 To 9
If IsNumeric(Worksheets("Tabelle2").Cells(5, i).Value) And IsNumeric(Worksheets("Tabelle3").Cells(5, i).Value) And Worksheets("Tabelle3").Cells(5, i).Value <> 0 Then
Worksheets("Tabelle1").Cells(5, i).Value = Worksheets("Tabelle2").Cells(5, i).Value / Worksheets("Tabelle3").Cells(5, i).Value
End If
Next
variable i is your column as a number. A = 1, B = 2, Z = 26, AA = 27 and so on..
number 5 is your row
For example
Cells(5,1) is the same like Range("A5") or Cells(3,9) = Range("I3")
In my code above, it starts with column C (3) and stops with column I (9). Replace the Number 9 with the number of the Column FX (your last column) and edit the table Names then it should work.
I'm trying my excel file to:
Compare columns G and H
- If they have the same text -> go to the next row to continue the comparison
- If they don't have the same text -> Insert a row below G and then continue the comparison.
The result would be this:
Before running the macro (first column is G, second column is H):
After running the macro:
Can you help me with this, please?
Thanks a lot.
Something like this
Sub CompArray()
Dim G
Dim H
Dim X
Dim lngCnt As Long
Dim lngMark As Long
G = Range([g1], Cells(Rows.Count, "G").End(xlUp))
H = Range([H1], Cells(Rows.Count, "H").End(xlUp))
X = H
For lngCnt = 1 To UBound(X, 1)
If G(lngCnt - lngMark, 1) = H(lngCnt, 1) Then
X(lngCnt, 1) = G(lngCnt - lngMark, 1)
Else
lngMark = lngMark + 1
X(lngCnt, 1) = vbNullString
End If
Next
[g1].Resize(UBound(X), 1) = X
End Sub
You can select the range you want to look at and then loop through the rows.
Compare the cells, if they are not the same, select the right cell.
Then insert in new cell and move everything to 1 cell down
This code s a bit slow, because it selects the whole column.
You can change compare statement to make a different compare
Dim rngCompare As Range
Dim rowCount As Long
Dim iCount As Long
Set rngCompare = ActiveSheet.Columns("D:E")
rowCount = rngCompare.Rows.Count
For iCount = 1 To rowCount
If StrComp(rngCompare.Cells(iCount, 1), rngCompare.Cells(iCount, 2), vbTextCompare) <> 0 Then
rngCompare.Cells(iCount, 1).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next iCount