I've tried to make this Auto Fill Range on VBA but I don't know What is Wrong or even if it works.
it should fill all the ranges A1 to Z20 based on first and second cells of each columns.
If anyone else can do it works or what's wrong please fix it.
Sub test()
Dim i As Range
Dim a As Long
Do While Not Range("Z20").Value > 0
If a = 0 Then
a = 1
Else
End If
For Each i In Range("A:Z")
a = a + 1
i = Range(Cells(1, a), Cells(20, a))
Cells(1, a).Value = 1
Cells(2, a).Value = 2
Set SourceRange = Range(Cells(1, a), Cells(2, a))
Set fillRange = Range(i).Columns(a)
SourceRange.AutoFill Destination:=fillRange
Next
Loop
End Sub
Option Explicit
Sub test()
Dim c As Range
Dim a As Long
Dim sourceRange As Range
a = 1
Do While a <> 20
ActiveSheet.Cells(1, a) = 1
ActiveSheet.Cells(2, a) = 2
Set c = ActiveSheet.Range(Cells(1, a), Cells(20, a))
Set sourceRange = ActiveSheet.Range(Cells(1, a), Cells(2, a))
sourceRange.AutoFill Destination:=c
a = a + 1
Loop
End Sub
Related
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
I have a list with 3 variables in the sheet "Combined" in columns A; B; C.
The workbook contains 98 sheets, with those 3 variables still in A; B; C columns but in different combinations and with a fourth column which never repeats itself, as the sheets go on, which i need to bring in the "Combined" sheet, always adding another column for the next sheet I vlookup. : A B C + D(from the next sheet) + E(from the next sheet) and so on.
I have a UDF that Vlookups on 3 based on 3 criterias and a macro that cycles through the sheets and bring the values where i want them. The problem is, it's pretty slow, left it from yesterday and its on sheet 60. Any suggestions on improving it would greatly help, Thank you in advance!
Function ThreeVlookup(Table_Range As Range, Return_Col As Long, Col1_Fnd, Col2_Fnd, Col3_Fnd)
Dim rCheck As Range, bFound As Boolean, lLoop As Long
On Error Resume Next
Set rCheck = Table_Range.Columns(1).Cells(1, 1)
With WorksheetFunction
For lLoop = 1 To .CountIf(Table_Range.Columns(1), Col1_Fnd)
Set rCheck = Table_Range.Columns(1).Find(Col1_Fnd, rCheck, xlValues, xlWhole, xlNext, xlRows, False)
If UCase(rCheck(1, 2)) = UCase(Col2_Fnd) And UCase(rCheck(1, 3)) = UCase(Col3_Fnd) Then
bFound = True
Exit For
End If
Next lLoop
End With
If bFound = True Then
ThreeVlookup = rCheck(1, Return_Col)
Else
ThreeVlookup = ""
End If
End Function
Sub test()
Dim lookupVal1 As Range, lookupVal2 As Range, lookupVal3 As Range, myString As Variant, n&, u As Long
n = Sheets("Combined").[A:A].Cells.Find("*", , , , xlByRows, xlPrevious).Row
u = 4
For j = 2 To Worksheets.Count
For i = 1 To n
Set lookupVal1 = Sheets("Combined").Cells(i, 1)
Set lookupVal2 = Sheets("Combined").Cells(i, 2)
Set lookupVal3 = Sheets("Combined").Cells(i, 3)
myString = ThreeVlookup(Sheets(j).Range("A:D"), 4, lookupVal1, lookupVal2, lookupVal3)
Sheets("Combined").Cells(i, u) = myString
Next i
u = u + 1
Next j
End Sub
Use Arrays to speed it up, my friend! Load all your sheets (or just the current sheet in the loop) into an array in VBA's memory and do the .CountIf and .Find on arrayVar(row) instead of Table_Range.Columns(1).
You will be really surprised how much quicker it goes. Do it!
Here's a tutorial I like on arrays...
http://www.cpearson.com/excel/ArraysAndRanges.aspx
Here's a guy who speed-tested an application like yours...
https://fastexcel.wordpress.com/2011/10/26/match-vs-find-vs-variant-array-vba-performance-shootout/
The basics is like this:
Sub Play_With_Arrays()
Dim varArray() As Variant
Dim lngArray() As Long
ReDim varArray(1 To 1000)
ReDim lngArray(1 To 1000)
For A = 1 To 1000
lngArray(A) = A / 2
varArray(A) = A / 2 & " examples"
Next
searchterm = 345
For B = 1 To 1000
If lngArray(B) = searchterm Then
FoundRow = B
End If
Next
searchterm2 = "5 ex"
FoundStrRowCount = 0
For C = 1 To 1000
If InStr(1, varArray(C), searchterm2, vbBinaryCompare) Then
FoundStrRowCount = FoundStrRowCount + 1
End If
Next
MsgBox (FoundRow & " in long array and " & FoundStrRowCount & " in var array")
End Sub
Something like this should be much faster:
Public Function ThreeVLookup(ByVal arg_Col1LookupVal As Variant, _
ByVal arg_Col2LookupVal As Variant, _
ByVal arg_Col3LookupVal As Variant, _
ByVal arg_LookupTable As Range, _
ByVal arg_ReturnColumn As Long) _
As Variant
Dim rConstants As Range, rFormulas As Range
Dim rAdjustedTable As Range
Dim aTable As Variant
Dim i As Long
On Error Resume Next
Set rConstants = arg_LookupTable.SpecialCells(xlCellTypeConstants)
Set rFormulas = arg_LookupTable.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
Select Case (Not rConstants Is Nothing) + 2 * (Not rFormulas Is Nothing)
Case 0: ThreeVLookup = vbNullString
Exit Function
Case -1: Set rAdjustedTable = rConstants
Case -2: Set rAdjustedTable = rFormulas
Case -3: Set rAdjustedTable = Union(rConstants, rFormulas)
End Select
If WorksheetFunction.CountIfs(rAdjustedTable.Resize(, 1), arg_Col1LookupVal, rAdjustedTable.Resize(, 1).Offset(, 1), arg_Col2LookupVal, rAdjustedTable.Resize(, 1).Offset(, 2), arg_Col3LookupVal) = 0 Then
ThreeVLookup = vbNullString
Exit Function
End If
aTable = rAdjustedTable.Value
For i = LBound(aTable, 1) To UBound(aTable, 1)
If aTable(i, 1) = arg_Col1LookupVal And aTable(i, 2) = arg_Col2LookupVal And aTable(i, 3) = arg_Col3LookupVal Then
ThreeVLookup = aTable(i, arg_ReturnColumn)
Exit Function
End If
Next i
End Function
Sub tgr()
Dim wb As Workbook
Dim wsCombined As Worksheet
Dim ws As Worksheet
Dim aResults() As Variant
Dim aCombined As Variant
Dim i As Long, j As Long
Set wb = ActiveWorkbook
Set wsCombined = wb.Sheets("Combined")
aCombined = wsCombined.Range("A1").CurrentRegion.Value
ReDim aResults(1 To UBound(aCombined, 1) - LBound(aCombined, 1) + 1, 1 To wb.Sheets.Count - 1)
For i = LBound(aCombined, 1) To UBound(aCombined, 1)
j = 0
For Each ws In wb.Sheets
If ws.Name <> wsCombined.Name Then
j = j + 1
aResults(i, j) = ThreeVLookup(aCombined(i, 1), aCombined(i, 2), aCombined(i, 3), ws.Range("A:D"), 4)
End If
Next ws
Next i
wsCombined.Range("D1").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub
I have code here which loops through a list of files; opening them, extracting data and moving it into the main workbook. What i am looking to do get it so the data for abel is in columns c and d but then put varo in f and g etc. the problem that i see is that the placement code is inside the loop so for each i it will just write over the previous line instead of being in a different column all together!
Sub Source_Data()
Dim r
Dim findValues() As String
Dim Wrbk As Workbook
Dim This As Workbook
Dim sht As Worksheet
Dim i
Dim tmp
Dim counter
Dim c As Range
Dim firstAddress
Dim rng As Range
ReDim findValues(1 To 3)
findValues(1) = "abel"
findValues(2) = "varo"
findValues(3) = "Tiger"
counter = 0
r = Range("A1").End(xlDown).Row
Set rng = Range(Cells(1, 1), Cells(r, 1))
Set This = ThisWorkbook
For Each tmp In rng
Workbooks.Open tmp
Set Wrbk = ActiveWorkbook
Set sht = ActiveSheet
For i = 1 To 3
With sht.Range(Cells(1, 1), Range("A1").SpecialCells(xlCellTypeLastCell))
Set c = .Find(findValues(i), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Offset(0, 2).Value
Do
This.Activate
tmp.Offset(0, 2).Value = tmp.Value
tmp.Offset(0, 3).Value = firstAddress
Set c = .FindNext(c)
counter = counter + 1
Loop While Not c Is Nothing And c.Value = firstAddress
End If
End With
Wrbk.Activate
Next
Wrbk.Close
Next tmp
End Sub
**EDIT:**I know it can be done by adding a multiplier of "i" to the offset value but this makes things bigger than they need to be if i wish to search for 50 keywords
Here is my answer, hope to help you, and as always, if you need an improvement, just tell me.
Sub Source_Data()
Dim r
Dim findValues() As String
Dim Wrbk As Workbook
Dim This As Workbook
Dim sht As Worksheet
Dim i
Dim tmp
Dim counter
Dim c As Range
Dim firstAddress
Dim rng As Range
Dim ColNum 'the columns number var
ReDim findValues(1 To 3)
findValues(1) = "abel"
findValues(2) = "varo"
findValues(3) = "Tiger"
counter = 0
r = Range("A1").End(xlDown).Row
Set rng = Range(Cells(1, 1), Cells(r, 1))
Set This = ThisWorkbook
For Each tmp In rng
Workbooks.Open tmp
Set Wrbk = ActiveWorkbook
Set sht = ActiveSheet
For i = 1 To 3
With sht.Range(Cells(1, 1), Range("A1").SpecialCells(xlCellTypeLastCell))
Set c = .Find(findValues(i), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Offset(0, 2).Value
Do
This.Activate
Select Case i 'Test var i (the value)
Case "abel" 'in case the value (that is a string) is equal to...
ColNum = 1 'set the var, with the number of the column you want
Case "varo" 'in case the value...
ColNum = 2 'Set the column...
Case "Tiger"
ColNum = 3
Case Else 'In case that the i var not match with anyvalue take this column number
ColNum = 20 'the garbage!
End Select
tmp.Offset(0, ColNum).Value = tmp.Value 'Put the value in the selected columns
tmp.Offset(0, ColNum + 1).Value = firstAddress 'and put the value to the next column of the
'selected column
Set c = .FindNext(c)
counter = counter + 1
Loop While Not c Is Nothing And c.Value = firstAddress
End If
End With
Wrbk.Activate
Next
Wrbk.Close
Next tmp
End Sub
Note:
You need to set the ColNum var to the values that you need, put there the numbers of the columns you really need to store the value of i and the next line is to put the address of the i var
You can just change these two lines:
tmp.Offset(0, 2).Value = tmp.Value
tmp.Offset(0, 3).Value = firstAddress
To this
tmp.Offset(0, 2 + (i-1)*2).Value = tmp.Value
tmp.Offset(0, 3 + (i-1)*2).Value = firstAddress
I have two columns of numbers, together they will be unique (composite key). I would like to create an unique ID number (third column) similar to how MS Access would use a primary key. I would like to do this in VBA but I am stuck on how to do it.
My VBA in excel isn't very good so hopefully you can see what I've started to attempt. it may be completely wrong... I don't know?
I don't know how to make the next concatenation and I am unsure about how to go down to the next row correctly.
Sub test2()
Dim var As Integer
Dim concat As String
concat = Range("E2").Value & Range("F2").Value
var = 1
'make d2 activecell
Range("D2").Select
Do Until concat = ""
'if the concat is the same as the row before we give it the same number
If concat = concat Then
var = var
Else
var = var + 1
End If
ActiveCell.Value = var
ActiveCell.Offset(0, 1).Select
'make the new concatination of the next row?
Loop
End Sub
any help is appreciated, thanks.
Give the code below a try, I've added a loop which executes for each cell in the E Column. It checks if the concat value is the same as the concat value in the row above and then writes the id to the D cell.
Sub Test2()
Dim Part1 As Range
Dim strConcat As String
Dim i As Long
i = 1
With ThisWorkbook.Worksheets("NAME OF YOUR SHEET")
For Each Part1 In .Range(.Cells(2, 5), .Cells(2, 5).End(xlDown))
strConcat = Part1 & Part1.Offset(0, 1)
If strConcat = Part1.Offset(-1, 0) & Part1.Offset(-1, 1) Then
Part1.Offset(0, -1).Value = i
Else
i = i + 1
Part1.Offset(0, -1).Value = i
End If
Next Part1
End With
End Sub
Something like this should work, this will return a Unique GUID (Globally Unique Identifier):
Option Explicit
Sub Test()
Range("F2").Select
Do Until IsEmpty(ActiveCell)
If (ActiveCell.Value <> "") Then
ActiveCell.Offset(0, 1).Value = CreateGUID
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Public Function CreateGUID() As String
CreateGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function
If you walk down column D and examine the concatenated values from column E and F with the previous row, you should be able to accomplish your 'primary key'.
Sub priKey()
Dim dcell As Range
With Worksheets("Sheet12")
For Each dcell In .Range(.Cells(2, 4), .Cells(Rows.Count, 5).End(xlUp).Offset(0, -1))
If LCase(Join(Array(dcell.Offset(0, 1).Value2, dcell.Offset(0, 2).Value2), ChrW(8203))) = _
LCase(Join(Array(dcell.Offset(-1, 1).Value2, dcell.Offset(-1, 2).Value2), ChrW(8203))) Then
dcell = dcell.Offset(-1, 0)
Else
dcell = Application.Max(.Range(.Cells(1, 4), dcell.Offset(-1, 0))) + 1
End If
Next dcell
End With
End Sub
You could use collections as well.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range, LstRw As Long
Dim Cell As Range
Dim vNum As Variant, c As Range, y
LstRw = Cells(Rows.Count, "E").End(xlUp).Row
Set Rng = Range("E2:E" & LstRw)
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value & Cell.Offset(, 1), CStr(Cell.Value & Cell.Offset(, 1))
Next Cell
On Error GoTo 0
y = 1
For Each vNum In cUnique
For Each c In Rng.Cells
If c & c.Offset(, 1) = vNum Then
c.Offset(, -1) = y
End If
Next c
y = y + 1
Next vNum
End Sub
i have an excel sheet like so:
HEADING <--A1 HEADING <-- this is B1
dhg kfdsl
56 fdjgnm
hgf fdkj
tr
465 gdfkj
gdf53
ry 4353
654 djk
354 <-- a12 blah <-- this is B12
I'm trying to put the range of cells in column A into a variant and remove any data from that variant if the cell in column B (for the same row in column A) is blank. Then i want to copy that variant to a new column (ie col c)
so my expected result is:
HEADING <--C1
dhg
56
hgf
465
ry
654
354 <-- C8
this is the code i have so far:
Dim varData As Variant
Dim p As Long
varData = originsheet.Range("B2:B12")
For p = LBound(varData, 1) To UBound(varData, 1)
If IsEmpty(varData(p, 1)) Then
remove somehow
End If
Next p
Dim bRange As range
Set bRange = originsheet.range("B2:B12")
Dim aCell, bCell, cCell As range
Set cCell = originsheet.Cells(2, 3) 'C2
For Each bCell In bRange
If bCell.Text <> "" Then
Set aCell = originsheet.Cells(bCell.Row, 1)
cCell.Value2 = aCell.Value2
Set cCell = originsheet.Cells(cCell.Row + 1, 3)
End If
Next bCell
Personally, I think your making this simple job harder, but here's how to do it the way you wanted:
Public Sub Test()
Dim Arange As Variant, Brange As Variant, Crange() As Variant
Dim i As Integer, j As Integer
Arange = Range("A2:A12")
Acount = Application.WorksheetFunction.CountA(Range("B2:B12"))
Brange = Range("B2:B12")
j = 1
ReDim Crange(1 To Acount, 1 To 1)
For i = 1 To UBound(Arange)
If Brange(i, 1) <> "" Then
Crange(j, 1) = Arange(i, 1)
j = j + 1
End If
Next i
Range("C2:C" & j) = Crange
End Sub
Try:
With ActiveSheet.UsedRange
.Cells(2, "C").Resize(.Rows.Count).Value = Cells(2, "A").Resize(.Rows.Count).Value
.Cells(2, "B").Resize(.Rows.Count).SpecialCells(xlCellTypeBlanks).Offset(, 1).Delete shift:=xlUp
End With
EDIT:
This is better:
With Range("A2", Cells(Rows.Count, "A").End(xlUp))
Cells(2, "C").Resize(.Rows.Count).Value = .Value
.Offset(, 1).SpecialCells(xlCellTypeBlanks).Offset(, 1).Delete shift:=xlUp
End With
You could also do it with advanced filter and no VBA.
Sub Main()
Dim rValues As Range
Dim vaIn As Variant
Dim vaTest As Variant
Dim aOut() As Variant
Dim i As Long
Dim lCnt As Long
Set rValues = Sheet1.Range("A2:A12")
vaIn = rValues.Value
vaTest = rValues.Offset(, 1).Value
ReDim aOut(1 To Application.WorksheetFunction.CountA(rValues.Offset(, 1)), 1 To 1)
For i = LBound(vaIn, 1) To UBound(vaIn, 1)
If Len(vaTest(i, 1)) <> 0 Then
lCnt = lCnt + 1
aOut(lCnt, 1) = vaIn(i, 1)
End If
Next i
Sheet1.Range("C2").Resize(UBound(aOut, 1)).Value = aOut
End Sub