How can I run a loop in VBA so that the sequence looks like in green an pink color?
Because when I use this code is actually just paste all number 1. not increase.
ThisWorkbook.Sheets("Main").Range("E2:E" & iLast).FillDown
This may not be the cleanest way, but it will do the trick.
Sub InsertSequenceAndColours()
Dim ws As Worksheet
Dim rng As Range
Dim iLast As Integer
Dim i As Integer
Dim iSeq As Integer
Dim iColRGB(2, 3) As Integer
Dim iIncremColour As Integer 'used to determine the colour to use
Dim iColour As Integer
'set RGB Colours; change as needed
'colour 0 (green)
iColRGB(0, 1) = 146
iColRGB(0, 2) = 208
iColRGB(0, 3) = 80
'colour 1 (pink)
iColRGB(1, 1) = 255
iColRGB(1, 2) = 225
iColRGB(1, 3) = 236
'change to 0 if you want to start with colour 1 (pink)
iIncremColour = 1
'declare worksheet to work on
Set ws = ThisWorkbook.Worksheets(Sheet1.Name)
With ws
'find last row
iLast = .Cells(.Rows.Count, "C").End(xlUp).Row
'loop through column C
For i = 2 To iLast
iSeq = iSeq + 1
If .Cells(i, 3).Value <> .Cells(i - 1, 3).Value Then
iSeq = 1
iIncremColour = iIncremColour + 1
End If
'assign Seq. No. to cell (column E)
.Cells(i, 5).Value = iSeq
'find if iIncremColor is odd or even. output: 0 or 1
iColour = iIncremColour Mod 2
'assign colour to col C D E
.Range(Cells(i, 3), Cells(i, 5)).Interior.Color = _
RGB(iColRGB(iColour, 1), iColRGB(iColour, 2), iColRGB(iColour, 3))
Next i
End With
End Sub
It finds out the Seq "1" (Col E) by finding the first occurrence of "No" (Col C); Seq "2, 3" are just incremental (so it will work also with more than 3 occurrences).
Same with colour. For each "Seq 1" it increments a number; by checking if this number is odd or even it assign one colour or the other.
Please Note I use worksheet codename to work (if you're not familiar with it, please google it), which I strongly advise since it will work even if you decide to change the name of your worksheet in excel.
When VBA requests to work with worksheet name or index, you can trick it by using codename.Name or codename.Index.
Approach via array
You can fill an array and write it back to your target range:
Sub FlexibleRange()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Main") ' << change to your sheet name
Dim start As Long, last As Long, i As Long ' declare variables
start = 2: last = 100 ' <~~ change to your individual rows
Dim v: ReDim v(start To last, 1 To 1) ' variant datafield array, counter
For i = start To last
v(i, 1) = (i - start) Mod 3 + 1 ' assign values
Next i
ws.Range("E" & start & ":E" & last) = v ' write numbers to column E
End Sub
I got to solve it.
i use this formula
=MOD(ROW()-2,3)+1.
Thank's you all..appreciate your help. <3
Related
I need the expert help in VBA as I am new. Actually I am looking for Vba code for Consecutive Count on the bases of two column (Serial Number and Alert Code) on button click event. The Column row are not fixed (dynamically change). The Consecutive count is maximum repeat count for Alert Code per Serial number. This should display in output worksheet as per max repeat Alert count per Serial number
Input Worksheet:
Expected Output :
The repeat count work as below pattern from Input sheet (Just for reference only).
Mine source code as below but this does not reference the 1st Column Serial Number (This only work for One column like AlertCode) :
Sub ConsecutiveCount()
Dim lr As Long, c As Range, a As Long
Application.ScreenUpdating = False
lr = Worksheets("Count2").Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range("B2:B" & lr)
If c.Value <> c.Offset(1).Value Then
a = Cells(c.Row, 3).End(xlUp).Row
' Range(Cells(c.Row, 4), Cells(c.Row, 4).End(xlUp).Offset(1)).Value = c.Row - a
Cells(c.Row, 3).Value = c.Row - a
Else
End If
Next c
Application.ScreenUpdating = True
End Sub
Current Output (Serial number not included)
Screenshot(s) / here(♪) refers:
Named ranges/setup
First, define a couple of named ranges to assist with referencing / formulating in VBA:
Name: range_data: dynamic range that references the two columns of interest (here, col 1&2 in Sheet1):
Refers to: =Sheet1!$D$3:OFFSET(Sheet1!$E$3,COUNTA(Sheet1!$E$3:$E$99995)-1,0,1,1)
Name: range_summary_startcell: a static range that references the desired upper-left cell of the output table / summary.
Refers to: =Sheet1!$G$3
The summary table itself shall comprise a number of rows (depending upon range_data) and 3 columns (given the input/Q) - this will be produced by the macro (code below) and can be seen in screenshot above (G3:I5) - the macro functions shall determine the appropriate dimensions automatically
Code
With these two named ranges (i.e. 'range_data' & 'range_summary_startcell') defined, the following VB code produces the desired output per your Q:
Sub Macro_Summary()
'
'JB_007 07/01/2022
'
'
Application.ScreenUpdating = True
Range("range_summary_startcell").Select
ActiveCell.Formula2R1C1 = "=UNIQUE(range_data)"
ActiveSheet.Calculate
x = ActiveCell.End(xlDown).Row
Set range_count = ActiveCell.Offset(0, 2)
range_count.Select
range_count.Formula2R1C1 = _
"=COUNTIFS(INDEX(range_data,0,2),RC[-1],INDEX(range_data,0,1),RC[-2])"
Selection.AutoFill Destination:=Range(range_count, range_count.Offset(x - range_count.Row))
ActiveSheet.Calculate
End Sub
Caveats: assumes you have Office 365 compatible version of Excel
GIF - Running Macro
Notes (♪) saved as macro-free workbook for your own security if you wish to download underlying workbook - otherwise identical to screenshot(s) in this proposed soln.
Sub ConsecutiveCount()
Dim srcLastRow As Long, cntConsec As Long, i As Long
Dim rng As Range
Dim srcArr() As Variant
Dim srcSht As Worksheet
Dim destsht As Worksheet
Dim destArr() As Variant
Dim combID As String
Dim splitID As Variant
Application.ScreenUpdating = False
Set srcSht = Worksheets("Input")
Set destsht = Worksheets("Output")
With srcSht
srcLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 ' include 1 blank line
srcArr = .Range(.Cells(2, "A"), .Cells(srcLastRow, "B"))
End With
Dim dict As Object
Dim dKey As Variant
Set dict = CreateObject("Scripting.dictionary")
cntConsec = 0
For i = LBound(srcArr) To UBound(srcArr)
cntConsec = cntConsec + 1
If i <> UBound(srcArr) Then
If srcArr(i, 1) <> srcArr(i + 1, 1) Or srcArr(i, 2) <> srcArr(i + 1, 2) Then
combID = srcArr(i, 1) & "|" & srcArr(i, 2)
If dict.Exists(combID) Then
' check if sum is more
If dict(combID) < cntConsec Then ' If new max for combination
dict(combID) = cntConsec
End If
Else
' add to dictionary
dict(combID) = cntConsec
End If
cntConsec = 0
End If
End If
Next i
ReDim destArr(1 To dict.Count, 1 To 3)
i = 0
For Each dKey In dict.keys
splitID = Split(dKey, "|")
i = i + 1
destArr(i, 1) = splitID(0)
destArr(i, 2) = splitID(1)
destArr(i, 3) = dict(dKey)
Next dKey
destsht.Range("A2").Resize(UBound(destArr), 3).Value = destArr
Application.ScreenUpdating = True
End Sub
I am working on a project where I need to populate the column headings with incremental values (increased by 1) until the Last Column.
The code is working OK but the value in the column headings is NOT increased by 1. It is just taking the original value and place it over all columns.
Could you help me?
My code so far:
Sub LastColumn_PopulateHeadings()
'Declare variable for Last row (Prior FY)
Dim LastColumn As Integer
Dim i As Integer
'Find the last Column used
LastColumn = Range("XFD4").End(xlToLeft).Column
'populate headings with column values UNTIL LAST COLUMN
' Loop to populate the heading until LAST column
i = 8
Do While i < LastColumn
'MsgBox (LastColumn)
Cells(4, i).Value = Cells(4, i).Value + 1
i = i + 1
Loop
End Sub
I find your code a little strange, but probably i am missing something. Anyway this one should work:
Sub LastColumn_PopulateHeadings()
'Declare variable for Last row (Prior FY)
Dim LastColumn As Integer
Dim i As Integer
Dim IntCounter01 As Integer '<<<<<<ADDED LINE (1 of 3)
'Find the last Column used
LastColumn = Range("XFD4").End(xlToLeft).Column
'populate headings with column values UNTIL LAST COLUMN
' Loop to populate the heading until LAST column
i = 8
IntCounter01 = 1 '<<<<<<ADDED LINE (2 of 3)
Do While i < LastColumn
'MsgBox (LastColumn)
Cells(4, i).Value = IntCounter01
i = i + 1
IntCounter01 = IntCounter01 + 1 '<<<<<<ADDED LINE (3 of 3)
Loop
End Sub
I took your code and added 3 lines. You could also use a For-Next cycle instead of using a Do-While-Loop cycle since you already know your maximal value. Something like:
For i = i To LastColumn - 1
Cells(4, i).Value = IntCounter01
IntCounter01 = IntCounter01 + 1
Next
You could also use a formula to cover your range instead of picking each cell one by one. Like this:
Sub LastColumn_PopulateHeadings()
'Declarations.
Dim IntFirstColumn As Integer
Dim IntLastColumn As Integer
Dim IntRow As Integer
Dim IntFirstValue
Dim RngRange01 As Range
'Setting variables.
IntFirstValue = 1
IntRow = 4
IntFirstColumn = 8
IntLastColumn = Range("XFD4").End(xlToLeft).Column
'Setting first value in the first cell.
Cells(IntRow, IntFirstColumn).Value = IntFirstValue
'Setting RngRange01.
Set RngRange01 = Range(Cells(IntRow, IntFirstColumn + 1), Cells(IntRow, IntLastColumn - 1))
'Setting formulas in RngRange01.
RngRange01.FormulaR1C1 = "=RC[-1]+1"
'Copy-pasting the values in RngRange01.
RngRange01.Value = RngRange01.Value
End Sub
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
I need to find out how to write some basic code that will take each cell's value (which will be an ID number) from a selected range, then match it to a cell in a master workbook, copy said cell's entire row, then insert it into the original document in place of the ID number. Here's the kicker: certain ID numbers may match with several items, and all items that have that number must be inserted back into the document. Here's an example:
Master Document Workbook
A B C D A B C D
1 a ab ac 2
2 b bc bd 3
2 b be bf
3 c cd de
I would select the cells containing 2 and 3 in the Workbook, which after running the code would give me this:
Workbook
A B C D
2 b bc bd
2 b be bf
3 c cd de
Here's what I have going on so far but it's a total mess. The only thing it's managed to successfully do is store the selected range in the Workbook I want to paste to. It won't compile past that because I don't understand much of the syntax in VBA:
Sub NewTest()
Dim rng As Range
Dim FirstRow As Range
Dim CurrentCol As String
Dim FirstRowVal As Integer
Dim CurrentColVal As Variant
Dim rngOffset As Range
CurrentCol = "Blah"
Set FirstRow = Application.InputBox("Select the row containing your first raw material", Type:=8)
FirstRowVal = FirstRow.Row
Set rng = (Application.InputBox("Select the cells containing your IC numbers", "Obtain Materials", Type:=8))
Set rngOffset = rng.Offset(0, FirstRowVal)
CurrentColVal = rng.Column
Call CopyPaste
End Sub
Sub CopyPaste()
Dim Blah As Range
Set x = Workbooks.Open("Workbook Path")
Workbooks.Open("Workbook Path").Activate
Set y = Workbooks.Open("Master Path")
Workbooks.Open("Master Path").Activate
With x
For Each Cell In rng
x.Find(rng.Cell.Value).Select
If Selection.Offset(0, -1) = Selection Then
Selection.EntireRow.Copy
Selection = Selection.Offset(0, -1)
Else
Selection.EntireRow.Copy
Blah = Selection
End If
Workbooks.Open("Workbook Path").Activate
Sheets("Formula Sheet").Select
Blah.Insert (rng.Cell)
End
Sheets("sheetname").Cells.Select
Range("A1").PasteSpecial
'Sheets("sheetname").PasteSpecial
.Close
End With
With x
.Close
End With
End Sub
Would very much appreciate anyone who could help point me in the right direction. Thanks.
I'll bite, you can use the output array to populate any range on any worksheet.
Sub FindAndMatch()
Dim arrMatchFrom() As Variant, arrMatchTo() As Variant, arrOutput() As Variant
Dim i As Integer, j As Integer, counter As Integer
counter = 0
arrMatchFrom = Range("A2:D6")
arrMatchTo = Range("G2:G3")
For i = LBound(arrMatchTo, 1) To UBound(arrMatchTo, 1)
For j = LBound(arrMatchFrom, 1) To UBound(arrMatchFrom, 1)
If arrMatchTo(i, 1) = arrMatchFrom(j, 1) Then
counter = counter + 1
ReDim Preserve arrOutput(4, counter)
arrOutput(1, counter) = arrMatchTo(i, 1)
arrOutput(2, counter) = arrMatchFrom(j, 2)
arrOutput(3, counter) = arrMatchFrom(j, 3)
arrOutput(4, counter) = arrMatchFrom(j, 4)
End If
Next
Next
For i = 1 To counter
For j = 1 To 4
Debug.Print arrOutput(j, i)
Cells(9 + i, j) = arrOutput(j, i)
Next
Next
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.