I would like to create a VBA macro that will auto number all cells in column 'A' to a single decimal place, if and only if they have a value in column 'B'. Every time there is a row that does not have a value in column 'B', column 'A' should re-start numbering at the next integer.
IE:
|COLUMN A | COLUMN B|
|:-------:|:-------:|
| 1.1 | TEXT |
| 1.2 | TEXT |
| 1.3 | TEXT |
| 1.4 | TEXT |
| 1.5 | TEXT |
| | *NO TEXT* |
| 2.1 | TEXT |
| 2.2 | TEXT |
| 2.3 | TEXT |
| | *NO TEXT* |
| 3.1 | TEXT |
| 3.2 | TEXT |
| 3.3 | TEXT |
| 3.4 | TEXT |
I think this is pretty self-explanatory, but post up if anything confuses you:
Option Explicit
Private Sub numberCells()
Dim totalRows As Long
Dim i As Long
Dim baseNumber As Long
Dim count As Integer
totalRows = ActiveSheet.UsedRange.Rows.count
baseNumber = 1
i = 2
Do While i <= totalRows
If Range("B" & i).Value <> "" Then
count = count + 1
Range("A" & i).Value = baseNumber & "." & count
Else
baseNumber = baseNumber + 1
count = 0
End If
i = i + 1
Loop
End Sub
I like using .Areas,
Here's my version
Sub Do_It_Good()
Dim RangeArea As Range, c As Range, LstRw As Long, sh As Worksheet, Rng As Range
Set sh = Sheets("Sheet1")
With sh
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
Set Rng = .Range("B2:B" & LstRw)
y = 0
For Each RangeArea In Rng.SpecialCells(xlCellTypeConstants, 23).Areas
y = y + 1
x = 0
For Each c In RangeArea.Cells
c.Offset(, -1) = y & "." & 1 + x
x = x + 1
Next c
Next RangeArea
End With
End Sub
Related
I'm trying to set up a nested loop that can tie together different columns only when the column in question has data.
What I have is a table like this:
|Aname |aterm |amod |
| | | |
|Smith, Bob | | |
| | | |
| | | |
| | 2/6/2017| |
| | | |
| | |Module 1 |
| | | |
|Smith, John | | |
| | | |
| | | |
| |5/12/2017| |
| | |Module 6 |
| | | |
| | |Module 4 |
| | | |
| |6/12/2017| |
| | | |
| | |Module 10|
| | |Module 5 |
What I am trying to do is tie the columns together like so:
|aname |aterm |amod |
|Smith, Bob | 02/6/2017 | Module 1 |
|Smith, John | 5/12/2014 | Module 6 |
|Smith, John | 5/12/2014 | Module 4 |
|Smith, John | 6/12/2014 | Module 10 |
|Smith, John | 6/12/2014 | Module 5 |
Below is the code I put together to pull this off. Unfortunately, the printing is picking up the aname dozens of time, the aterm intermittently, and the amod not at all.
Sub looper()
Dim rng As Range
Dim rng2 As Range
Dim rng3 As Range
aname = ""
aterm = ""
amod = ""
Set listenroll = [table1[aname]]
Set atermrange = [table1[aterm]]
Set amodrange = [table1[amod]]
For Each rng In listenroll
If IsEmpty(rng) = False Then
Set aname = rng
For Each rng2 In atermrange
If IsEmpty(rng2) = False Then
Set aterm = rng2
For Each rng3 In amodrange
If IsEmpty(rng3) = False Then
Set amodrange = rng3
Range("I1").End(xlDown).Offset(1, 0) = aname
Range("J1").End(xlDown).Offset(1, 0) = aterm
Range("K1").End(xlDown).Offset(1, 0) = amod
End If
Next rng3
End If
Next rng2
End If
Next rng
Does anyone know what the problem is here?
I have an alternative solution for you. This is basically the same thing with YowE3K's code, however there is one more for loop and one less if statement. This is because, instead of using table names I used column A B C assuming your table is there, and also stored the values in an array.
Try this:
Sub looper()
Dim i As Long, j As Long, LastCell As Long
Dim arr() As String
ReDim arr(2)
With Sheets("Sheet1")
LastCell = .UsedRange.Rows.Count
For i = 2 To LastCell
For j = 1 To 3
If Not IsEmpty(.Cells(i, j)) Then
arr(j - 1) = .Cells(i, j)
If j = 3 Then
.Cells(.Rows.Count, "I").End(xlUp).Offset(1, 0) = arr(0)
.Cells(.Rows.Count, "J").End(xlUp).Offset(1, 0) = arr(1)
.Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0) = arr(2)
End If
End If
Next j
Next i
End With
End Sub
You only need one loop:
Sub looper()
Dim aname As String
'Dim aterm As String
Dim aterm As Date
Dim amod As String
aname = ""
'aterm = ""
aterm = 0
amod = ""
Set listenroll = [table1[aname]]
Set atermrange = [table1[aterm]]
Set amodrange = [table1[amod]]
Dim r As Long
For r = 1 to amodrange.Rows.Count
'Record value of AName whenever it changes
If Trim(listenroll(r, 1).Value) <> vbNullString Then
aname = Trim(listenroll(r, 1).Value)
End If
'Record value of ATerm whenever it changes
If Trim(atermrange(r, 1).Value) <> vbNullString Then
'aterm = Trim(atermrange(r, 1).Value)
aterm = CDate(atermrange(r, 1).Value)
End If
'Write output each time there is something in amod
If Trim(amodrange(r, 1).Value) <> vbNullString Then
amod = Trim(amodrange(r, 1).Value)
Range("I1").End(xlDown).Offset(1, 0) = aname
Range("J1").End(xlDown).Offset(1, 0) = aterm
Range("K1").End(xlDown).Offset(1, 0) = amod
End If
Next
Note: I'm not sure how to modify aterm to match your question's example, but I'm hoping that's just a typo in the example.
And, FWIW, you have one major error in your existing code at the point where you say Set amodrange = rng3. I'm not sure whether that is the only error.
I am trying to write an excel function that will output a range containing a subset of values based on a value range and a filter range and a criteria.
Using the example below, I want to pass Range("A2:A5") and Range("B2:B5") to output Range("C2:C5")
+---+-------+-------+-------+
| | A | B | C |
+---+-------+-------+-------+
| 1 | Name | Group | Output|
| 2 | Nick | A | Nick |
| 3 | Marc | A | Marc |
| 4 | Manny | B | Luck |
| 5 | Luck | A | |
+---+-------+-------+-------+
I have written the code below so far. it works fine in vba but not when I call the function within the sheet
D1.function -> =filterFN(A2:A6,B2:B6,D1,"B")
:
Sub test()
Sheets("Sheet2").Range("D1") = filterFN(Sheets("Sheet2").Range("A1:A6"), Sheets("Sheet2").Range("B1:B6"), Sheets("Sheet2").Range("D1"), "B")
End Sub
Function filterFN(valueRange As Range, filterRange As Range, outputRange As Range, criteriaStr As String)
Dim Arr1() As Variant ' declare an unallocated array.
Dim Arr2() As Variant
Dim Arr3(50) As Variant
Dim i, j As Integer
Arr1 = valueRange
Arr2 = filterRange
For i = 1 To UBound(Arr1, 1)
If Arr2(i, 1) = criteriaStr Then
Arr3(j) = Arr1(i, 1)
j = j + 1
End If
Next i
[outputRange].Resize(UBound(Arr3)) = Application.Transpose(Arr3)
filterFN = Arr3(0)
End Function
Many thanks in advance
You cannot use a function called from a worksheet to update that worksheet (or another sheet): all you can do is return a value to the calling cell(s)
http://support.microsoft.com/kb/170787
I'm using two files let's name it File 1 and File 2 my script append the data from File 1 to File 2 now every time I append File 2 i want insert Current Date from my Column.
File 1:
Header 1 | Header 2 | Header 3|
1 | 1 | |
1 | 1 | |
File 2
Header 1 | Header 2 | Header 3|
a | a | 3/3/2016|
a | a | 3/3/2016|
Sample Output:
Header 1 | Header 2 | Header 3|
a | a |3/3/2016 |
a | a |3/3/2016 |
1 | 1 |4/4/2016 |
1 | 1 |4/4/2016 |
As you can see the sample output above inserted the current date in `Header 3.
My problem is that if i append the data from File 2 it densest return the current date in Header 3 but if I append it again it updates the last one.
to make it clear let's give another example.
Sample Out: (This is the output of my script)
Header 1 | Header 2 | Header 3|
a | a |3/3/2016 |
a | a |3/3/2016 |
1 | 1 | |
1 | 1 | |
If I append again the data from File 1 this is now the output
Header 1 | Header 2 | Header 3|
a | a |3/3/2016 |
a | a |3/3/2016 |
1 | 1 |4/4/2016 |
1 | 1 |4/4/2016 |
1 | 1 | |
1 | 1 | |
I want to insert the current date every time i append a new data, my code insert the date one step behind and i'm connfused gagin with my code #.# Please Help me!
My Code:
Public Sub addweeklydata()
Dim file1 As Excel.Workbook
Dim file2 As Excel.Workbook
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Dim Rng As Range
Set Sheet1 = Workbooks.Open(TextBox1.Text).Sheets(1)
Set Sheet2 = Workbooks.Open(TextBox2.Text).Sheets(1)
lastRow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
Sheet2.Cells(i, 4).Value = Date
Set Rng = Sheet1.Range("A1").CurrentRegion 'assuming no blank rows/column
Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, Rng.Columns.Count) 'exclude header
Next
Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize( _
Rng.Rows.Count, Rng.Columns.Count).Value = Rng.Value
Sheet2.Parent.Close True 'save changes
Sheet1.Parent.Close False 'don't save
End Sub
You have to add the data after you copy the files, something like this:
Public Sub addweeklydata()
Dim file1 As Excel.Workbook
Dim file2 As Excel.Workbook
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Dim Rng As Range
Set Sheet1 = Workbooks.Open(TextBox1.Text).Sheets(1)
Set Sheet2 = Workbooks.Open(TextBox2.Text).Sheets(1)
lastRow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
Sheet2.Cells(i, 4).Value = Date
Set Rng = Sheet1.Range("A1").CurrentRegion
Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, Rng.Columns.Count)
Next
Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize( _
Rng.Rows.Count, Rng.Columns.Count).Value = Rng.Value
lastRow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
if not cbool(len(Sheet2.Cells(i, 4))) then Sheet2.Cells(i, 4) = Date
next i
Sheet2.Parent.Close True 'save changes
Sheet1.Parent.Close False 'don't save
End Sub
I have not tested it, but the idea of the second loop is to add data only if the cell is empty. You can optimize it.
Here is a faster way of doing it
Logic:
Read the text file in memory and store it in an array
Insert date in the 3rd column
Code
Sub Sample()
Dim MyData As String, strData() As String
Dim TempAr
'~~> Read the text file in memory in one go
Open "C:\File1.Txt" For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
For i = LBound(strData) To UBound(strData)
TempAr = Split(strData(i), "|")
If Len(Trim(TempAr(2))) = 0 Then TempAr(2) = Date
strData(i) = Join(TempAr, "|")
Debug.Print strData(i)
Next i
'~~> strData now has all the data from file1 with date in it
'~~> Simply append the array to the 2nd text file
End Sub
I need your help! how can i make a condition that will count of cells in column E that is greater or equal than column f, if one of column is zero no count
A | B | C | D | E | F
--------+-------+-------+-------+-------+--------
A1021 | A10 | A | RX1 | 99 | 98 '-------> 1'
A1021 | A10 | A | RX1 | 0 | 98
A1021 | A10 | A | RX1 | 99 | 98
A1021 | A10 | A | RX1 | 99 | 0
A1021 | A10 | A | RX1 | 98 | 98 '------> 1'
Answer is 2
'First variant
'========================================================================
Sub test()
Dim N As Long, LastRow As Long, ocell As Range
N = 0
LastRow = Cells(Rows.Count, 5).End(xlUp).Row
For Each ocell In ActiveSheet.Range("E1:E" & LastRow)
If ocell.Value >= ocell.Offset(, 1).Value And _
ocell.Value > 0 And ocell.Offset(, 1).Value > 0 Then
N = N + 1
End If
Next
MsgBox N
End Sub
'Second variant
'========================================================================
Sub test2()
Dim v As Long
v = Evaluate("sumproduct((E:E>=F:F)*(E:E>0)*(F:F>0))")
MsgBox v
End Sub
So i have a matrix formatted as so:
| | joe | michelle | tom |
|:-----: |:---: |:--------: |:---: |
| red | 1 | 0 | 1 |
| blue | 0 | 1 | 0 |
| green | 0 | 0 | 0 |
I'm trying to write VBA in excel to create two columns based on this table. If the cell inside the matrix is equal to "1", then I want to write the column name and row name into a list. So for example, because row "red" has a "1" in columns "joe" and "tom", and row "blue" has a "1" under "michelle", my new table would be like this:
| joe | red |
| tom | red |
| michelle | blue |
Here is the VBA i wrote so far, but it doesn't work and i hit a road block.
sub subname()
dim i as integer
for i = 1 to 3
if cells(2,i).value=1 then
cell(5,i).value = cells(1,i).value
end if
next i
end sub
You have only one cycle ...
Dim x As Integer
Range("B19").Select
x = 4
For i = 1 To 3 ' Row
For e = 1 To 3 ' Column
If ActiveCell.Offset(i, e).Value = "1" Then
x = x + 1
ActiveCell.Offset(x, 0).Value = ActiveCell.Offset(0, e).Value
ActiveCell.Offset(x, 1).Value = ActiveCell.Offset(i, 0).Value
End If
Next
Next
I consider B19 the top_left corner of the table ...
Ok the correct code is:
Dim i As Integer
For i = 1 To 3
If Cells(2, i + 1).Value = 1 Then
Cells(5, 1).Value = Cells(1, i + 1).Value
End If
Next i
If the top_left of the table is A1 The error is the reference of i. You need to add 1 or change the cycle from 2 to 4.The second "error" it's to put the value in cell(5,i) instead of cells(5,1). In that case you have to put the name in a fix position. In a cycle you change in Cells(5+e,1)...
You can use this code also.
Sub prabhat()
Dim rng As Range
Dim r As Integer
Dim c As Integer
Dim lastRow As Integer
Dim lastRow2 As Integer
Set rng = Range("a2:d4")
For Each dng In rng
lastRow = Range("E" & Rows.Count).End(xlUp).Row
lastRow2 = Range("F" & Rows.Count).End(xlUp).Row
If dng.Value = 1 Then
r = dng.Row
c = dng.Column
Range("E" & lastRow + 1).Value = Cells(r, 1).Value
Range("F" & lastRow2 + 1).Value = Cells(1, c).Value
End If
Next dng
End Sub