Well I have the following problem, I have 2 columns as follows:
A B
"X" 1
"Y" 1
"Z" 0
"W" 2
What I want to do is find a way to create new columns C and D or better still, update columns A and B as follows:
C D
"X" 1
"Y" 1
"Z" 0
"W (1)" 1
"W (2)" 1
Any suggestion or ideas on how can i do this will be much appreciated.
This is not supposed to be a code writing forum. You are expected to show some effort.
Sub split_()
Dim P1 As Range
Range("C1:D99999").Clear
Set P1 = Range("A1").CurrentRegion
a = 1
For i = P1(1).Row To P1.Rows.Count
If P1(i, 2) > 1 Then
For j = 1 To P1(i, 2)
Cells(a, 3) = P1(i, 1) & " (" & j & ")"
Cells(a, 4) = 1
a = a + 1
Next j
Else
Cells(a, 3) = P1(i, 1)
Cells(a, 4) = P1(i, 2)
a = a + 1
End If
Next i
End Sub
Related
I´ve an Excel file with 10 Columns. In columns 2, 3, 4 I have a number or a dash.
If the sum of these 3 cells is greater than 1, I need to replace that entire row with n rows that have only one of the columns with the value 1 but the other cells stay the same.
Example
1 - - #-> leave it as is
- 2 - #-> replace that row with 2 rows : - 1 - ; - 1 -
2 - 1 #-> replace that row with 3 rows : 1 - - ; 1 - - ; - - 1;
I managed to iterate from bottom up, but I´m having trouble storing a row in memory, manipulate it and insert below.
Sub Test()
Dim rng As Range
Dim count20, count40, count45, total, i As Integer
Set rng = Range("A3", Range("A3").End(xlDown))
For i = rng.Cells.count To 1 Step -1
count20 = 0
count40 = 0
count45 = 0
total = 0
count20 = Cells(rng.Item(i).Row, 10).Value
If count20 > 1 Then
total = total + count20
End If
count40 = Cells(rng.Item(i).Row, 11).Value
If count40 > 1 Then
total = total + count40
End If
count45 = Cells(rng.Item(i).Row, 12).Value
If count45 > 1 Then
total = total + count45
End If
If total <> 0 Then
MsgBox total
End If
Next i
End Sub
EDIT 2
I’ve provided alternative code based on your latest comment. It uses columns J-L (10-12) as the numeric cells to be changed, and columns A-I (1-9) and M-AD (13-30) as the cells with text to be preserved. As before, sheet 1 starting in row 3 is assumed, and you can change this to whatever you need.
Option Explicit
Sub testJtoL()
Dim LastRow As Long, i As Long, j As Long, c As Long, _
insertR As Long, TopRow As Long, BottomRow As Long
Dim b As Range
Dim ws As Worksheet
'*** This code is based your values being in Columns J-L (10-12) in sheet 1 ***
'Set sheet 1 as ws
Set ws = Sheet1
'Sheet1 column J is used here to get your last row
LastRow = ws.Cells(Rows.Count, 10).End(xlUp).Row
'*** This code is based your values starting in Row 3 ***
For c = LastRow To 3 Step -1
'Determine number of rows to insert based on sum of that row
insertR = Application.WorksheetFunction.Sum(Range(Cells(c, 10), Cells(c, 12))) - 1
If insertR = 0 Then GoTo skip
'STEP 1 insert the correct number of rows
With ws.Range(Cells(c + 1, 1), Cells(c + insertR, 30))
.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End With
'STEP 2 fill the values into the correct number of rows
insertR = insertR + 1
With ws.Range(Cells(c, 1), Cells(c, 30))
.Resize(insertR, 30).Value = .Value
End With
TopRow = c
If insertR = 0 And c = 3 Then
BottomRow = c
Else
BottomRow = c + insertR - 1
End If
'STEP 3 replace all numbers with 1 or "-"
'Replace numbers in column J
If ws.Range(Cells(c, 10), Cells(c, 10)).Value = "-" Then GoTo SkipA
i = ws.Range(Cells(c, 10), Cells(c, 10)).Value
j = 1
For Each b In ws.Range(Cells(TopRow, 10), Cells(BottomRow, 10))
If j <= i Then
b.Value = 1
b.Offset(0, 1).Value = "-"
b.Offset(0, 2).Value = "-"
Else
b.Value = "-"
End If
j = j + 1
Next b
SkipA:
'Replace numbers in column K
j = 1
For Each b In ws.Range(Cells(TopRow, 11), Cells(BottomRow, 11))
If b.Value = "-" Then GoTo SkipB
i = b.Value
If j <= i Then
b.Value = 1
b.Offset(0, 1).Value = "-"
Else
b.Value = "-"
End If
j = j + 1
SkipB:
Next b
'Replace numbers in column L
j = 1
For Each b In ws.Range(Cells(TopRow, 12), Cells(BottomRow, 12))
If b.Value = "-" Then GoTo SkipC
i = b.Value
If j <= i Then
b.Value = 1
Else
b.Value = "-"
End If
j = j + 1
SkipC:
Next b
skip:
Next c
End Sub
need to create a list in excel for all possible combinations (unique): Let say there are 5 buttons (e.g A B C D E) and 3 are selected. For any single combination, any selected button can't be repeated in that combination.
I should get 60 unique combinations ( 5 1 ) * ( 4 1 ) * ( 3 1 ) = 60. I need to create this list in excel.
e.g have A B C D E buttons. 3 buttons combinations: A B C; C B A; D A C; C D A; A D C; etc.
By "unique" I assume that you want to exclude things like AAD or ABB.
Consider:
Option Explicit
Sub Kombos()
Dim arr(1 To 5) As String
Dim brr(1 To 5) As String
Dim i As Long, j As Long, k As Long
Dim N As Long, V As String
arr(1) = "A"
arr(2) = "B"
arr(3) = "C"
arr(4) = "D"
arr(5) = "E"
N = 1
For i = 1 To 3
For j = i + 1 To 4
For k = j + 1 To 5
Cells(1, N) = arr(i) & arr(j) & arr(k)
N = N + 1
Next k
Next j
Next i
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 1 To 10
V = Cells(1, i).Value
brr(1) = Left(V, 1)
brr(2) = Mid(V, 2, 1)
brr(3) = Right(V, 1)
Cells(2, i) = brr(1) & brr(3) & brr(2)
Cells(3, i) = brr(2) & brr(1) & brr(3)
Cells(4, i) = brr(2) & brr(3) & brr(1)
Cells(5, i) = brr(3) & brr(1) & brr(2)
Cells(6, i) = brr(3) & brr(2) & brr(1)
Next i
End Sub
Each column is a different combination of 5 elements taken 3 at a time. (10 columns)
The rows below the first row list the various permutations of the column header.
I am slowly learning how to do some very basic routines in Excel VBA, but I dont know how to tackle this one.
How can I go from data in one row looking like this :
11-Jun,27.3,28.3,12-Jun,27.2,28.3,13-Jun,26.7,28.4,14-Jun,26.7,28.4
to 3 columns.
First column with date, 2nd with first value, 3rd with the second value ?
Thanks
Put your data in A1.
This will loop the data back to the desired column based on if there is a remainder left after dividing.
Option Explicit
Sub splitData()
Dim i, rownum, colnum As Integer
Dim str As Variant
colnum = 1
rownum = 2
str = Split(Cells(1, 1).Value, ",")
For i = 0 To UBound(str)
If i Mod 3 = 2 Then
Cells(rownum, 3).Value = "'" & str(i)
End If
If i Mod 3 = 1 Then
Cells(rownum, 2).Value = "'" & str(i)
End If
If i Mod 3 = 0 Then
rownum = rownum + 1
Cells(rownum, 1).Value = "'" & str(i)
End If
Next i
End Sub
Or maybe something like this :
Sub test()
x = Split(Range("A1"), ",")
y = (UBound(x) + 1) / 3
P = 1
For i = 1 To y
For Z = 1 To 3
Cells(i + 3, Z).Value = x(P - 1)
P = P + 1
Next
Next
End Sub
I have the below code in part of my excel vba that I need to amend but could do with some help understanding.
In cells T, W, and Z there is a sum if formula in row 2, this VBA replicates this formula down to the last row. I am trying to update the formula so that it does this for column T,W,Z,AC and AF
I've changed the 1-3 to 1-5 but it is debugging at the doc(ii) line.
Please could anyone help me up understand and update it.
Dim a, k, i As Long, ii As Long, t As Long, w(1 To 3), x, dic(1 To 3) As Object
With Range("k2", Range("k" & Rows.Count).End(xlUp))
k = .Value
a = .Columns(8).Resize(, 10).Value
End With
For i = 1 To 3
Set dic(i) = CreateObject("Scripting.Dictionary")
dic(i).CompareMode = 1
ReDim x(1 To UBound(a, 1), 1 To 1) As Double: w(i) = x
Next
For i = 1 To UBound(a, 1)
For ii = 1 To 3
dic(ii)(a(i, (ii - 1) * 3 + ii + 1)) = i
Next
Next
For i = 1 To UBound(a, 1)
For ii = 1 To 3
t = (ii - 1) * 3 + ii
If dic(ii).exists(a(i, t)) Then
x = w(ii)
x(dic(ii)(a(i, t)), 1) = x(dic(ii)(a(i, t)), 1) + k(i, 1)
w(ii) = x
End If
Next
Next
For i = 1 To 3
Cells(2, (i + 4) * 4).Resize(UBound(a, 1)).Value = w(i)
Next
End Sub
I am having a problem with my code, a compile error "type mismatch". Especially in the following line
If comp.Cells(r, c) = "" Then
i tried switching r and c with a number separately and it worked, but not together. Here's the full code
Sub missing_data()
Dim comp As Worksheet
Set comp = Sheets("Compiled")
empty_cells = 0
sixten_comp = 0
For r = 2 To 103
For c = 5 To 18
'searching for empty cells
If comp.Cells(r, c) = "" Then
If (c + 1998) > comp.Cells(r, 3) Then
empty_cells = empty_cells + 1
comp.Cells(r, c).Interior.ColorIndex = 13
'If comp.Cells(r, 1).Interior.ColorIndex = 1 Then sixten_comp = sixten_comp + 1
End If
End If
Next c
Next r
MsgBox "Number of total cells left is " & empty_cells
'MsgBox "Number of total cells left in 16 companies is " & sixten_comp
End Sub
The cells you are checking may contain an error returned by a formula so add another condition to check if the cell doesn't contain an error and if not, proceed to check other conditions....
If Not IsError(comp.Cells(r, c)) Then
If comp.Cells(r, c) = "" Then
If (c + 1998) > comp.Cells(r, 3) Then
empty_cells = empty_cells + 1
comp.Cells(r, c).Interior.ColorIndex = 13
'If comp.Cells(r, 1).Interior.ColorIndex = 1 Then sixten_comp = sixten_comp + 1
End If
End If
End If
Try:
If comp.Cells(r, c).Value = "" Then
instead of:
If comp.Cells(r, c) = "" Then
it should work without a problem