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
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'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 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
sheet1 sheet2 sheet3
---------
| |
V V * V-----
123 | A 123 | 456 C | |
* | B 123 | 789 D | |
| C 123 | 345 E | |
^ |
|-----------------
Can I look up 123 from sheet 1 to sheet 2 to return a letter (but that letter must appear in sheet 3 (C), look up the letter that is in sheet 3 and return 456? the problem is there are multiple 123's in sheet 2; I'm only used to dealing with unique numbers. Can it go A is not in sheet 3 so go to next letter until hits C. then lookup value to the left which is 456.
Thanks
Using VBA, inside a Module, write this new function:
Public Function LookFx(Sh1 As Range, Sh2 As Range, Sh3 As Range) As String
Dim BaseVal As String
Dim FoundV As Boolean
Dim SecVal As String
Application.Volatile
BaseVal = Sh1.Value
FoundV = False
For Each xx In Sh2
If xx.Value = BaseVal Then
SecVal = xx.Offset(0, -1).Value
For Each yy In Sh3
If yy.Value = SecVal Then
LookFx = yy.Offset(0, -1).Value
End If
Next
End If
Next
End Function
the value to be add in the function are:
Lets this is your data:
Sheet1:
Sheet2 :
Sheet 3:
The code below will loop through the values in sheet2 if a match is found it will loop through the values in sheet3. If a match is found it will be displayed, else it will c continue its loop in sheet.
Sub main()
Dim intValue As Integer
Dim i As Integer
Dim j As Integer
Dim strChar As String
intValue = Sheet1.Cells(1, 1)
For i = 1 To 3
If intValue = Sheet2.Cells(i, 2) Then
strChar = Sheet2.Cells(i, 1)
For j = 1 To 3
If strChar = Sheet3.Cells(j, 2) Then
MsgBox (Sheet3.Cells(j, 1))
Exit Sub
End If
Next j
End If
Next i
End Sub
Okay so I have a bunch of data in table format like this:
|A | B |
------------------------
1 |102 | a, b, d, f, g |
------------------------
2 |104 | a, c, e |
------------------------
I'm new to using macros or using VBA, so is it possible to create a macro to map, individually, what's in column B to column A like this:
|A | B |
---------------
1 |102 | a |
---------------
2 |102 | b |
---------------
3 |102 | d |
---------------
etc..
I've looked online at a bunch of VBA tutorials and don't see anything like this.
Try below code :
Sub sample()
Dim lastRow As Long, i As Long, j As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
temp = Split(Cells(i, 2), ",")
For j = LBound(temp) To UBound(temp)
Cells(Cells(Rows.Count, 3).End(xlUp).Row + 1, 3).Value = Cells(i, 1)
Cells(Cells(Rows.Count, 4).End(xlUp).Row + 1, 4).Value = temp(j)
Next
Next
End Sub