Move cells with pattern search and copy - excel

I would like to achieve following in VBA
Input Workbook1
Index Value
1 a
2 a
3 b
4 c
5 a
6 b
7 a
8 c
Output Workbook2
I would like to have output in following format so that I can generate graph with same X axis
Index Value 1 Value 2 Value 3
1 a
2 a
3 b
4 c
5 a
6 b
7 a
8 c
I am using two functions, the first one to move two columns from workbook 1 to workbook2
Sub MOVE()
Sheets("Workbook1").Columns("A").Copy Sheets("Sheet1").Range("A1")
Sheets("Workbook1").Columns("B").Copy Sheets("Sheet1").Range("B1")`
end sub
2nd function is:
Sub move_a()
Worksheets("Sheet1").Activate
Dim myR As Range
Set myR = Range("B:B").Find("PATTERN_A")
Do While Not myR Is Nothing
myR.Insert xlToRight
Set myR = Range("B:B").FindNext
Loop
end sub
but 2nd one is not working

I've put your two operations into a single sub procedure. First the copy is performed on the entire block and then cells are inserted according to the value in column B to shift the values to the right.
Sub move_it_all()
Dim rw As Long, a As Long
With Worksheets("Sheet1")
Worksheets("Workbook1").Cells(1, 1).CurrentRegion.Copy _
Destination:=.Cells(1, 1)
For rw = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
a = Asc(UCase(Right(.Cells(rw, 2).Value2, 1)))
If a > 65 And a <= 90 Then
.Cells(rw, 2).Resize(1, a - 65).Insert shift:=xlToRight
End If
.Cells(1, a - 63) = "Value" & a - 64
Next rw
End With
End Sub
I will admit to some confusion over the worksheet named Workbook1. You might have to adjust the source and target of the Copy & Paste.
        

Related

How to generate an alphanumeric tree changes with criteria?

I'm working on excel sheet template used for SAP System and I have 2 columns looks like below:
Column C Column E
Level Element Code
3 ABCD.01.01.01
4 ABCD.01.01.01.01
4 ABCD.01.01.01.02
4 ABCD.01.01.01.03
3 ABCD.01.01.02
4 ABCD.01.01.02.01 'I Want to Restart Numbering Here
4 ABCD.01.01.02.02
4 ABCD.01.01.02.03
I succeeded in level 3 to be automated in the whole sheet by Macro as below
Sub AutoNumber3()
Dim Rng, C As Range
Dim Lrow As Long
Dim i As Integer
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Worksheets("Union").Range("C2:C" & Lrow)
i = 1
For Each C In Rng.Cells
If C.Value = 3 Then
For i = 1 To i Step 1
C.Offset(0, 2).Value = "ABCD.01.01." & i
Next i
End If
Next C
End Sub
and I used the same for level 4 as below
Sub AutoNumber4()
Dim Rng, C As Range
Dim Lrow As Long
Dim i As Integer
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Worksheets("Union").Range("C2:C" & Lrow)
i = 1
For Each C In Rng.Cells
If C.Value = 4 Then
For i = 1 To i Step 1
C.Offset(0, 2).Value = "ABCD.01.01.01" & i
Next i
End If
Next C
End sub
I want to Restart the numbering of level 4 from 1 each time the cells values in the level column = 3 by using Do Until the next C.Value = 3, I = 1 But I can not put it correctly in the Autonumber4 procedure
Your help is highly appreciated since this sheet may reach to 50000 or 100000 rows which is impossible to fill them manually
Thanks, Regards
Moheb Labib
Try this
Sub AutoNumber()
Dim rngLevels As Range, cl As Range
Dim lLastRow As Long, i As Long
Dim sElemCode As String
Dim vLevelsCounter() As Long
With ThisWorkbook.Sheets("Union")
lLastRow = Evaluate("=COUNTA(" & .Name & "!C:C)")
lLastRow = WorksheetFunction.Max(lLastRow, .Cells(Rows.count, "C").End(xlUp).Row)
Set rngLevels = .Range("C2:C" & lLastRow)
End With
For Each cl In rngLevels.Cells
' Uncomment "If" to use it on filtered data only
'If Not cl.EntireRow.Hidden Then
UpdateLevelsCounters vLevelsCounter, cl.Value
sElemCode = "ABCD"
For i = 1 To cl.Value
sElemCode = sElemCode & "." & Format(vLevelsCounter(i), "00")
Next i
cl.Offset(0, 2).Value = sElemCode
'End If
Next cl
End Sub
Function UpdateLevelsCounters(ByRef arr() As Long, lLevel As Long)
If lLevel < 1 Then Exit Function
Dim i As Long
ReDim Preserve arr(1 To lLevel)
For i = LBound(arr) To lLevel - 1
If arr(i) = 0 Then arr(i) = 1
Next i
arr(lLevel) = arr(lLevel) + 1
End Function
This should work for levels other than 3 and 4 as well (I hope)
You've not specified if your count will be always of two digits or not, and if it can be something like 01.20.99.99, but This formula can lead you in the good way (not tested with 100000 records)
=IF(C2=3;"ABCD.01.01."&TEXT(COUNTIF($C$2:C2;C2);"00");INDIRECT("E"&SUMPRODUCT(MAX(--($C$2:C2=3)*ROW($C$2:C2))))&"."&TEXT(SUMPRODUCT(--($C$2:C2=4)*--(ROW($C$2:C2)>SUMPRODUCT(MAX(--($C$2:C2=3)*ROW($C$2:C2)))));"00"))
This is how it works:
A) First, we check if cell in colum C is a 3 or 4. In case is 3, we do ;"ABCD.01.01."&TEXT(COUNTIF($C$2:C2;C2);"00"); This will count how many times does the number 3 appear in range $C$2:C2 and will concatenate to string ABCD.01.01. The trick here is using $C$2:C2, because it makes a range dynamic (but it can overload calculus times)
B) If not 3, then we do a really complext part I'm going to try to explain. Also, we use the trick of dynamic range
SUMPRODUCT(MAX(--($C$2:C2=3)*ROW($C$2:C2)))) this part is used twice. It will get the last row number of the last 3 value in column C.
Example:ROW($C$2:C6) will get an array of just row numbers, like {2;3;4;5;6}. --($C$2:C6=3) will return an array of zero/one depending if cell equals/not equals to 3, something like {1;0;0;0;1}. ($C$2:C6=3)*ROW($C$2:C6)) will multiply both arrays, so we get {1;0;0;0;1}*{2;3;4;5;6}={2;0;0;0;6}. And with MAX we get max value from that array, That 6 means the last position of a 3 value.
We use INDIRECT combined with the number of step 1 to get the text inside the cell
SUMPRODUCT(--($C$2:C2=4)*--(ROW($C$2:C2)>SUMPRODUCT(MAX(--($C$2:C2=3)*ROW($C$2:C2)))));" Everything after the > is the same logic than step 1. It will return the row number of last cell containing a 3. Part SUMPRODUCT(--($C$2:C2=4)*--(ROW($C$2:C2) will just get row numbers of those cells containing a 4 value, and which row numbers are higher than value obtained in step 1. That way you make sure how to count the cells containing 4 values, between two cells containing 3 values.
We concatenate everything to form the final string.
TEXT functions are just used to force the calculation to be 2 digits.
You can use this manually, or you can insert the formula using VBA, drag down, and then converting everything into values (I would probably would do that). Something like this could work.
Sub Macro1()
Dim LR As Long
LR = Range("C" & Rows.Count).End(xlUp).Row 'last non blank row in column c
Range("E2").FormulaR1C1 = _
"=IF(RC[-2]=3,""ABCD.01.01.""&TEXT(COUNTIF(R2C3:RC[-2],RC[-2]),""00""),INDIRECT(""E""&SUMPRODUCT(MAX(--(R2C3:RC[-2]=3)*ROW(R2C3:RC[-2]))))&"".""&TEXT(SUMPRODUCT(--(R2C3:RC[-2]=4)*--(ROW(R2C3:RC[-2])>SUMPRODUCT(MAX(--(R2C3:RC[-2]=3)*ROW(R2C3:RC[-2]))))),""00""))"
Range("E2").AutoFill Destination:=Range("E2:E" & LR), Type:=xlFillDefault
Range("E2:E" & LR) = Range("E2:E" & LR).Value 'paste into values
End Sub
NOTE: Probably you will need to adapt this depending on the results (we do not know if the count of 3 or 4 values can have 3 or 4 digits, and so on).

Code doesn't work as expected. VBA code to copy values from one sheet to another if condition met

I am writing a VBA code to copy values from one sheet to another if the values in column B of the Source sheet are bigger or equal to 10.
I am able to copy the values from the Source sheet to the Target sheet. However, the values copied are wrong.
I have tried changing the condition (values bigger than 10) to see what the output would be. The values are not as expected.
Sub findValues()
Dim c As Range
Dim b As Integer
Dim Source As Worksheet
Dim Target
Set Source = ActiveWorkbook.Worksheets("Source2")
Set Target = ActiveWorkbook.Worksheets("Code Trial2")
b = 2
For Each c In Source.Range("B2:B:20")
If c.Value >= 10 Then
Source.Cells(b, "A").Copy
Target.Cells(b, "A").PasteSpecial xlPasteValues
Source.Cells(b, "B").Copy
Target.Cells(b, "B").PasteSpecial xlPasteValues
b = b + 1
End If
Next c
End Sub
The Source Sheet contains the following:
Val Number
A 1
B 2
C 3
D 10
E 12
F 13
I expect the output to be: 10, 12, 13
However, in the Target sheet I get: 1, 2, 3
Actual Output
This should do it:
Option Explicit
Sub findValues()
Dim c As Range
Dim b As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Source2")
Set Target = ActiveWorkbook.Worksheets("Code Trial2")
b = 2
For Each c In Source.Range("B2:B20")
If c.Value >= 10 Then
Target.Cells(b, "A").Value = c.Offset(0, -1).Value
Target.Cells(b, "B").Value = c.Value
b = b + 1
End If
Next c
End Sub

Confused in looping

What code can give me this result?
Copy value in A1, Worksheet 1 to Worksheet 2 column A 4 times (e.g A1 - A4)
Then Copy value in A2, Worksheet 1 to Worksheet 2 column A 4 times again (e.g A5 - A8), and so on.
Thank you!
Sub Moveit
'declare your variables
dim r as range
dim t as range
dim i as integer
'initialise your ranges
set r = worksheets(1).range("A1")
set t = worksheets(2).range("a1")
do 'begin looping
for i = 1 to 4 'do 4 times
t=r
set t = t.offset(1,0) 'move target down 1
next i
set r = r.offset(1,0) 'move source down 1
loop until r= "" 'repeat until you run out of sources
End Sub

Changing cell color to RGB values within Excel spreadsheet using VBA

I've essentially got 10 sets of RGB values in 30 columns (each value in their own cell) with repeated different RGB values in 8 rows below these. What I would like to do is color the cell of 10 cells to the right of these 30 to show a visual representation of the 10 colors (based on their set of RGB values) in all 8 of these rows. I've seen a few VBA examples out in the wild that sort of do something similar but more just on a individual set of RGB values. I was thinking I could create function like the following but that doesn't seem to work. Maybe a Sub routine would be required to do this but not sure where to start. Any help or direction would be appreciated.
Function RGB_Color(R As Integer, B As Integer, G As Integer)
RGB_Color = Application.ThisCell.Interior.Color = RGB(R, G, B)
End Function
You can start with this sub. It will color a range of your desire (Rc) with data from (Rs).
Sub ColorRGB(Rs As Range, Rc As Range)
Dim R As Long
Dim G As Long
Dim B As Long
Dim Address(1 To 3) As Long
Dim I As Integer: I = 1
For Each cell In Rs.Cells
Address(I) = cell.Value
I = I + 1
Next
R = Address(1)
G = Address(2)
B = Address(3)
Rc.Interior.Color = RGB(R, G, B)
End Sub
Test:
In this test, we're coloring the cell D1 with the contents from the range A1:C1.
Sub Test()
ColorRGB Sheet1.Range("A1:C1"), Sheet1.Range("D1")
End Sub
Result:
The code below uses the RGBColor Sub. It will define a lastrow long (8 in our case) so this can basically handle more rows. Then, it will take the first vertical range of 8 cells and set it in a Range object called r only to do a For Each loop on it later.
With every cell in the For Each loop, we're going to run with another For loop transversely (in direction of columns). The new For loop will run with step of 3 calling our ColorRGB function and telling it to take in the arguments supplied below.
Given the fact that the For loop runs with a step of 3, we've defined a counter for the colored cells called c that increments itself by 1 with each step of the For loop (its step is egal to 3).
I hope this logic is clear. There are obviously better methods to do this.
Sub ColorSheet(sheetname As string)
Dim r As Range
'defining lastrow which is 8
Dim lastrow As Long
With ThisWorkbook.Worksheets(sheetname)
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set r = .Range("A1", "A" & lastrow)
End With
Dim C As Integer: C = 30
For Each cell In r.Cells
For I = 1 To 30 Step 3
ColorRGB ThisWorkbook.Worksheets(sheetname).Range(cell.Offset(0, I - 1).Address(0, 0), cell.Offset(0, I + 1).Address(0, 0)), ThisWorkbook.Worksheets(sheetname).Range(cell.Offset(0, C).Address(0, 0))
C = C + 1
Next I
C = 30
Next
End Sub
This final sub will color the sheet name you provide it with.
Sub Test
ColorSheet("Sheet3")
'And so on...
End Sub
If your sheets are named like SheetX
Sub Test
Dim I as Integer
For I = 1 to 20
ColorSheet("Sheet"&I)
Next I
End Sub
Example:
Yours doesn't work because you're passing RGB_Color(R,B,G) to RGB(R,G,B)

SUM Function in VBA - not hard coding rows and columns

How do I use the lastRow variable in the sum function in vba? After I count the number of words in each row until the last row, I would like to add up the individual totals from each row into an overall total column but I do not want to hard code the range into the sum function in vba? Is there another way?
Example:
Column: A B C D E F
NRow 1: 2 3 4 5 6 7
NRow 2: 3 4 5 6 7 8
Total 3: 5 7 9 11 13 15
Want to avoid SUM(R[-2]C:R[-1]C)? I would like SUM(R[lastRow]C:R[-1]C) or something that would function in the same way.
Thank you!
Something like this which
Sets the usedrange on the active sheet from A1 to the last used cell in column F
Goes to the first cell below this range Cells(rng1.Cells(1).Row + rng1.Rows.Count, 1), resizes to the amount of columns in the range of interest (6 in this case)
Enters the forumula "=SUM(R[-" & rng1.Rows.Count & "]C:R[-1]C)" where rng1.Rows.Count gives the first row dynamically
code
Sub GetRange()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "F").End(xlUp))
Cells(rng1.Cells(1).Row + rng1.Rows.Count, 1).Resize(1, rng1.Columns.Count).Value = "=SUM(R[-" & rng1.Rows.Count & "]C:R[-1]C)"
End Sub
If you can guarantee that there is always data in column A then to find the last row you could do the following:
Option Explicit
Sub addSums()
Dim lstRow As Integer
With Excel.ThisWorkbook.Sheets("Sheet1")
lstRow = .Cells(.Rows.Count, 1).End(Excel.xlUp).Row
Dim j As Integer
For j = 1 To .Cells(1, .Columns.Count).End(Excel.xlToLeft).Column
.Cells(lstRow + 1, j) = "=SUM(R[-" & lstRow - 1 & "]C:R[-1]C)"
.Cells(lstRow + 1, j).Font.Bold = True
Next j
End With
End Sub
Seems to work ok on the following:
If your source data is coming frm an external source, the appropriate mechanism is:
Create a Named Data Range around the input table;
Set the inut table to automatically resize on refresh; and
Then use the Named Data Range in your functions.

Resources