I have data in a sheet which looks like
A B C D
1001 1002 1003
Phone 1 1 1
TV 1 1
Remote 1
AC 1 1 1
I want a macro to which gives Data in another sheet something like
Phone 1001;1002;1003
TV 1001;1003
Remote 1003
AC 1001;1002;1003
in 2 columns
This is Sample data, the columns and rows vary every time to large numbers say up to 1000.
So I need a macro to get the data from first row, only if corresponding cell has "1" in it.
This might help ..
Sub Init()
Dim x, y As Integer
Dim s As String
Dim xt As Worksheet
Set xt = Sheets("Sheet2")'----------> you may change this
For y = 2 To 6 '--------------------tv,remote,etc
s = ""
For x = 2 To 4 '------------------1001,1002,1003
If Cells(y, x) = 1 Then
If Len(s) > 0 Then s = s & "; "
s = s & Cells(1, x)
End If
Next
xt.Cells(y, 1) = Cells(y, 1)
xt.Cells(y, 2) = s
Next
End Sub
Related
I have stumbled upon a problem which solution seems to be very close but I still can't get it.
Code below is supposed to fill specific cells with a number between 1,2,3 so it looks like
row2 (as it starts from row2) - 1
row3 - 2
row4 - 3
row5 - 1
row6 - 2
...
Let's say that "range" variable returns 700 rows. I'd like to have above numbers in specified order only in these 700 rows however when I run the code pasted below it returns 3 times more filled cells. I'm more than certain it's somewhere in either first For or the inner one but I can't still bite it correctly :(
Sub level()
Set sf = ThisWorkbook.Sheets("formatted")
Dim range As Long
range = sf.Cells(Rows.Count, 6).End(xlUp).Row
x = 2
For i = 2 To range
For y = 1 To 3
sf.Cells(x, 9).Value = y
sf.Cells(x, 11).Value = y
x = x + 1
Next y
Next i
End Sub
Use Mod:
Sub level()
Set sf = ThisWorkbook.Sheets("formatted")
Dim rng As Long
rng = sf.Cells(Rows.Count, 6).End(xlUp).Row
Dim i As Long
For i = 2 To rng
sf.Cells(i, 9) = ((i - 2) Mod 3) + 1
Next i
End Sub
Hi I am trying to compare two sets of data by having indicators if they increased, decreased, or stayed the same. I was able to get it working on one column. My problem is I can't loop it on multiple columns.
Basically:
If A1 = C1 then D1.Value = 0
If A1 > C1 then D1.Value = 1
If A1 < C1 then D1.Value = 2
I've tried to do the "do while" to add increments on the columns but it did not work.
Sub ChangeIndicator2()
Dim i As Long
Dim a As Long
Dim b As Long
Dim x As Long
Dim y As Long
Dim ProgramCount As Long
i = 2
a = 8
b = 2
x = 0
y = 8
ProgramCount = 12
Do While y <= ProgramCount
For Each c In Worksheets("Sheet1").Range("A2:A20").Offset(x, y)
If Worksheets("Sheet1").Cells(i, a).Value = Worksheets("Sheet1").Cells(i, b).Value Then
c.Value = 0
ElseIf Worksheets("Sheet1").Cells(i, a).Value < Worksheets("Sheet1").Cells(i, b).Value Then
c.Value = 1
ElseIf Worksheets("Sheet1").Cells(i, a).Value > Worksheets("Sheet1").Cells(i, b).Value Then
c.Value = 2
End If
i = i + 1
Next c
a = a + 2
b = b + 2
y = y + 2
Loop
End Sub
Only the first column works, the second column only shows 0 values.
So basically, what you want to do is compare 2 columns which are 2 columns apart and repeat that on another pair of columns which is 8 columns from the first column. If my assumption is correct then have a go at this:
For i = 0 To (ProgramCount * 8) Step 8
With Worksheets("Sheet1").Range("A2:A20").Offset(, i + 3)
.FormulaR1C1 = "=IF(RC[-3]=RC[-1],0,IF(RC[-3]>RC[-1],1,2))"
.Value2 = .Value2
End With
Next
Adjust the offset to suit your needs (I may have misunderstood the actual columns you target to update). Hope this helps.
I am having some issues with my code any help would be greatly appreciated.
I have a range of data in a tab called Wheel Diameters and I need the following criteria to be met (Columns B6 to B28, G, L need to be less than 4000 and the cell values need to be 800 or less) the second is (Columns B35 to B54, G, L need to be more than 4000 but less than 5000 and the cell values need to be 800 or less) the third is (Columns B61 to B92, G, L need to be 9000 or greater and the cell values need to be 800 or less) for the information to be lifted into another tab called Wheel Diameters league.
The less than 4000 need to go into the wheel diameters league tab in columns A and B, the greater than 4000 but less than 5000 need to go into columns D and E, the greater than 9000 need to go into columns G and H.
Sub BUTTON5_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
'Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Wheel Diameters")
Set Target = ActiveWorkbook.Worksheets("Wheel Diameters League")
Target.Range("A2:B5000").Clear
j = 2 ' Start copying to row 2 in target sheet
For i = 1 To 3 'Number of ¿wees?
For Each c In Union(Source.Range(Cells(6, 5 * i - 2), Cells(28, 5 * i + 1)), Source.Range(Cells(35, 5 * i - 2), Cells(54, 5 * i + 1)), Source.Range(Cells(61, 5 * i - 2), Cells(92, 5 * i + 1)))
If c.Text < 4000 And c.Text <= 800 Then
Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
Target.Cells(j, 2) = Source.Cells(5, c.Column)
j = j + 1
ElseIf c.Text <= 800 And c.Text >= 4000 Then
Target.Cells(j, 4) = Source.Cells(c.Row, 5 * i - 3)
Target.Cells(j, 5) = Source.Cells(5, c.Column)
j = j + 1
End If
Next c
Next i
End Sub
Example of how it looks:
3405 - As it is greater than 800 the details Column 1 and 3405 will be lifted and copied into a second tab called 'Wheel Diameters League'
This works on your example data:
Dim Source As Worksheet
Dim Target As Worksheet
Dim rg As Range
Dim x As Long, y As Long, z As Long, tcol As Long, threshold As Long
Set Source = ActiveWorkbook.Worksheets("Wheel Diameters")
Set Target = ActiveWorkbook.Worksheets("Wheel Diameters League")
Set rg = Source.Range("B6:P92")
For x = 1 To rg.Columns.Count Step 5
For y = 1 To rg.Rows.Count
For z = 1 To 4
Select Case rg.Cells(y, x)
Case 0 To 3999
tcol = 2 ' column 'B'
threshold = 800
Case 4000 To 8999
tcol = 5 ' column 'E'
threshold = 864
Case Else
tcol = 8 ' column 'H'
threshold = 849
End Select
If rg.Cells(y, x + z) > 10 And rg.Cells(y, x + z) <= threshold Then
With Target.Cells(Rows.Count, tcol).End(xlUp)
.Offset(1, 0) = rg.Cells(y, x) 'write Coach No
.Offset(1, 1) = z 'write Axle No
.Offset(1, 2) = rg.Cells(y, x + z) 'write value
End With
End If
Next z
Next y
Next x
I've added a new variable called tcol, which is the target column we're writing the league data to. I've created a Select Case to decide what column it's set to, based on the axle class.
I've added threshold which is also based on axle class.
I've expanded the range down to P92 to read ALL the data.
I've added a test to ensure the value is above 10, not just below threshold. This prevents cells that are not axle data, but are axle headings from triggering the writing to the league table.
I've made the For.. Next loops for x and y more dynamic, in case your tables change size - in which case you just need to alter the rg range.
Lastly, I've added in the writing of the value to the table, as I hadn't noticed that requirement before.
I have an excel 2007 sheet where column names with data are all placed in one single column and I need to shift one column name to the left or right with data so that I can have separate columns. Can you create a VBA function where it reads all rows of the column and shift those columns with certain keywords. Such as:
A1 B1
1 **Category1**
Cat1 info here
**cf**
45
34
34
Sf
542
234
234
2 **Category2**
Cat2 info here
**cf**
76
23
67
**Sf**
678
987
3476
I Need to move "cf" column + data to a different column and paste it to its relevant category. So "cf" would shift right with data and move up along with its category. I would then delete the empty rows of B Column.
Finally had it figured out, Bad coding maybe but it works.. :)
Thanks All for your Help .
Sub test()
Dim i As Long
Dim toprow As Long
Dim z As Long
Dim count As Long
Dim b As Long
toprow = 3
b = toprow
For i = toprow To Cells(Rows.count, 1).End(xlUp).Row
If Not Cells(i, 1) = "" And Not Cells(i, 2) = "" Then
b = i
count = 0
z = i
End If
If Cells(i, 1) = "" Then
If Cells(i + 1, 1) = "" Then
z = i
If Not Cells(z + 1, 2) = "" Then
Cells(z + 1, 2).Cut Cells(b, 2)
i = b
b = z + 1
count = 0
ElseIf count = 0 Then
count = z
b = count
End If
End If
End If
Next i
End Sub
I need some help converting three colums into a matrix using excel macro.
Here is an example:
From this:
A A 0
A B 23
A C 3
B A 7
B B 56
B C 33
C A 31
C B 6
C C 5
to this:
A B C
A 0 23 3
B 7 56 33
C 31 6 5
Hope you can help me.
Thanks
Not quite sure what exactly you are meaning by matrix. For the code below I assumed you were looking for a way to read the data in the first two columns as Row and Column data of the output table. Assume the input data is in the Columns 1 - 3 of "Sheet1"
Sub ConvertTableOfData()
Dim testArray(1 to 3)
Dim chkROW as Integer
Dim chkCOL as Integer
Dim chkVAL as Integer
'// index the Row and Column headers
testArray(1) = "A"
testArray(2) = "B"
testArray(3) = "C"
'// Iterate through every row in the initial dataset
For i = 1 to Worksheets("Sheet1").Cells(1, 1).End(xlDown).Row
With Worksheets("Sheet1")
'// Assign the Output Row and Column values
'// based on the array indices
For j = 1 to UBound(testArray, 1)
If .Cells(i, 1) = testArray(j) Then
chkROW = j
End If
If .Cells(i, 2) = testArray(j) Then
chkCOL = j
End If
Next j
'// store the actual value
chkVAL = .Cells(i, 3)
End With
'// output table (in Sheet2)
With Worksheets("Sheet2")
.Cells(chkROW, chkCOL) = chkVAL
End With
Next i
'// Add headers to Output table
For i = 1 to 3
With Worksheets("Sheet2")
.Cells(i + 1, 1) = testArray(i)
.Cells(i, i + 1) = testArray(i)
End With
Next i
End Sub
You can also perform this without VBA.
Assume your table of data is in the range A1:C9.
Assume the first number (0) in the 3 by 3 grid of data is cell F3, with A, B, C in the row above, and A, B, C in the column to the left.
Enter the formula in cell F3 as
=INDEX($C$1:$C$9,SUMPRODUCT(--($A$1:$A$9=$E3),--($B$1:$B$9=F$2),ROW($A$1:$A$9)))
Copy this formula to all 9 cells in the 3 by 3 grid.
This generalized to any size of data.