I have two worksheets (one for input and another for output) and I'm trying to copy some information on cells along a row from the input to cells along a row on the output. My code stops if, on a separated list of ranges, there's no info. The code I'm using is like that right now:
Sub Txt_Manobra()
Dim x As Range
Dim i As Integer
Dim o As Integer
Dim p As Integer
Dim Txt1 As String
Dim Txt2 As Variant
For Each x In Worksheets("Formulario").Range("AK9:AK47").Cells
If x.Value <> "" Then Txt1 = x.Value
o = 8 + x.Count
For i = 1 To 7
p = 3 + i
Txt2 = Worksheets("Formulario").Range(o, p).Value
Worksheets("SdB pg1").Range(Txt1).Cells(1, i) = Txt2
Next i
Next x
End Sub
For each range value (x), it looks on the range txt1 (That is composed of only one row), and it should copy the values on range (D9:J9), one at a time and put on the range determined x (also only one row and with the same number of columns as D9:J9) then look on the next row (D10:J10) and so on.
I'm getting errors and I think this might be easier to do than I Think.
It's like that:
Input
And I want to tranfer to
Output
Each cell in the range "AK9:AK47" Contains a range like "P10:V10"
I haven't made it to work out to see if my "o" changes
If there are valid cell addresses in range AK9:AK47, then something like this should work for you. Note that using single letter variables is bad practice, and you can customize the code by adjusting the constants at the top.
Sub tgr()
Const sDestInfoCol As String = "AK"
Const lHeaderRow As Long = 8
Const lStartCopyCol As String = "D"
Const lFinalCopyCol As String = "J"
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rDestInfo As Range
Dim rDestTemp As Range
Dim lNumCols As Long
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Formulario")
Set wsDest = wb.Sheets("SdB pg1")
Set rDestInfo = wsData.Range(sDestInfoCol & lHeaderRow + 1, wsData.Cells(wsData.Rows.Count, sDestInfoCol).End(xlUp))
If rDestInfo.Row <= lHeaderRow Then Exit Sub 'No data
lNumCols = Columns(lFinalCopyCol).Column - Columns(lStartCopyCol).Column + 1
For Each rDestTemp In rDestInfo.Cells
With rDestTemp
If Evaluate("ISREF(" & .Text & ")") Then
wsDest.Range(.Text).Resize(1, lNumCols).Value = wsData.Cells(.Row, lStartCopyCol).Resize(1, lNumCols).Value
End If
End With
Next rDestTemp
End Sub
Related
I have an excel sheet which looks like this - All the data is numerical data. The actual sheet has a lot more rows & columns in reality.
https://i.imgur.com/E2HEdXF.png
What I Want to get out of this data is something like this - For each year, I want to sort A & F based on the year's numerical data. So not one sort, but one sort per year.
I don't think there is a simple method for doing this, so I was thinking of 2 possible ways
I export the data into some database & then use SQL queries to get the output I want - I assume there must be some databases which allow you import Excel data.
or
Write a VBA program which does the following - Copy Column D & E into another place & sort based on Column E. Then Copy Column D & F into another place & sort based on Column F & so on & so forth.
I have never done VBA, but I am programmer, so I assume it wouldn't be trouble to do this.
However, I was wondering if there is some other easier way to do it or if not, which of the above two would be a better way to do it.
Copy and Sort
The following will copy the data from columns D:G as column pairs consisting of the first column and each next column, to columns A:B of newly created worksheets of the workbook containing this code and finally sort them descendingly by column B. Already existing worksheets, to be created, will previously be deleted.
Adjust the values in the constants section.
Option Explicit
Sub copyAndSort()
Const sName As String = "Sheet1"
Const sFirst As String = "D1"
Const yCols As String = "E:G"
Const dFirst As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim yrg As Range
Dim rCount As Long
Dim cCount As Long
With sws.Range(sFirst)
Dim rOff As Long: rOff = .Row - 1
Dim sCell As Range
Set sCell = .Resize(.Worksheet.Rows.Count - rOff) _
.Find("*", , xlFormulas, , , xlPrevious)
If sCell Is Nothing Then Exit Sub
rCount = sCell.Row - rOff
Set srg = .Resize(rCount)
Set yrg = .Worksheet.Columns(yCols).Rows(.Row).Resize(rCount)
cCount = yrg.Columns.Count
End With
Dim sData As Variant: sData = srg.Value
ReDim Preserve sData(1 To rCount, 1 To 2)
Dim yData As Variant: yData = yrg.Value
Dim Result As Variant: ReDim Result(1 To cCount)
Dim c As Long, r As Long
For c = 1 To cCount
Result(c) = sData
For r = 1 To rCount
Result(c)(r, 2) = yData(r, c)
Next r
Next c
Erase yData
Erase sData
Dim dws As Worksheet
Dim drg As Range
Dim dName As String
Application.ScreenUpdating = False
For c = 1 To cCount
dName = Result(c)(1, 2)
On Error Resume Next
Set dws = Nothing
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dName
Set drg = dws.Range(dFirst).Resize(rCount, 2)
drg.Value = Result(c)
drg.Sort Key1:=drg.Cells(2), Order1:=xlDescending, Header:=xlYes
Next c
wb.Save
Application.ScreenUpdating = True
End Sub
How to fill an array with strings in VBA and get its lengh?
For example two cells might contain this info:
A1: "test 1"
A2: "test 2"
Dim example As String
Dim arreglito() As String
example = Range("A2").Value
arreglito(0) = example
example= Range("A1").Value
arreglito(1)= example
MsgBox arreglito(0)
subscript out of range
Dim example As String
Dim arreglito() As Variant
example = Range("A2").Value
arreglito(0) = example
MsgBox arreglito(0)
subscript out of range
Here is a method of adding a single column range from the worksheet to a string array (transpose may have some size restrictions. 2^16 is it?).
Have used a line by Flephal to get the range into a string array in one step.
Sub AddToArray()
Dim arreglito() As String
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("MySheet") 'change as appropriate
Dim srcRange As Range
Set srcRange = ws.Range("A1:A3")
arreglito = Split(Join(Application.Transpose(srcRange), "#"), "#")
MsgBox UBound(arreglito) + 1
End Sub
For more than one column transfer via a variant array:
Sub AddToArray2()
Dim arreglito() As String
Dim sourceArr()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("MySheet") 'change as appropriate
Dim srcRange As Range
sourceArr = ws.Range("A1:C3")
ReDim arreglito(1 To UBound(sourceArr, 1), 1 To UBound(sourceArr, 2))
Dim x As Long
Dim y As Long
For x = LBound(sourceArr, 1) To UBound(sourceArr, 1)
For y = LBound(sourceArr, 2) To UBound(sourceArr, 2)
arreglito(x, y) = CStr(sourceArr(x, y))
Next y
Next x
MsgBox UBound(arreglito, 1) & " x " & UBound(arreglito, 2)
End Sub
you can read entire excel range to array, its much faster than reading data from range cell by cell.
Sub testRerad()
Dim arr As Variant 'no brackets needed, I prefer to use variant
Dim numOfRows As Long, numOfCols As Long
arr = Sheets(1).Cells(1).Resize(10, 1).value 'arr will contain data from range A1:A10
'or
arr = Sheets(1).Range("A1").CurrentRegion.value 'arr will contain data from all continous data startig with A1
'get dimensions
numOfRows = UBound(a)
numOfCols = UBound(a, 2)
End Sub
be warned that this will always create multidimensional array (even if only 1 column) with dimensions 1 to y, 1 to x
I'm looking for VBA code to run in Excel to find and replace lots of words.
Basically, it will be a simple Excel file where Sheet1 contains phrases in 1 column which contains names to be replaced (not the whole phrase but one name which might consist of few words). Second sheet2 contains in 1 column values which I need to find in Sheet1 (there might be more than one time when value appears to be found in 1st column) and column which contains translation. I don't need Google API for this because names are very custom.
I came across to the following script but it does nothing basically.
Sub ReplaceValues()
Dim dataSht As Worksheet
Dim editSht As Worksheet
Dim dataRange As Range
Dim dataColumn As Long
Dim editColumn As Long
Dim dataEndRow As Long
Dim editEndRow As Long
'sheet that holds all the values we want to find
Set dataSht = Sheet2
'sheet we want to edit
Set editSht = Sheet1
Dim replaceValue As String
'replace value is empty string
replaceValue = ""
'set the column of the data sheet to A
dataColumn = 1
'set the colmun of the sheet to edit to A
editColumn = 5
dataEndRow = dataSht.Cells(dataSht.Rows.count, dataColumn).End(xlUp).Row
editEndRow = editSht.Cells(editSht.Rows.count, editColumn).End(xlUp).Row
'this is the range of the data that we're looking for
Set dataRange = dataSht.Range(dataSht.Cells(1, dataColumn),
dataSht.Cells(dataEndRow, dataColumn))
Dim count As Long
Dim val As String
For i = 1 To editEndRow
val = editSht.Cells(i, editColumn).Value
count = Application.WorksheetFunction.CountIf(dataRange, val)
If count > 0 And Trim(val) <> "" Then
editSht.Cells(i, editColumn).Value = replaceValue
End If
Next i
End Sub
Finally, I was able to do what I need with a very simple piece of code. Get trained folks!
Sub Test()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim FndList, x&
Set Sh1 = Sheets(1)
Set Sh2 = Sheets(2)
FndList = Sh2.Cells(1, 1).CurrentRegion
For x = 1 To UBound(FndList)
Sh1.Cells.Replace What:=FndList(x, 1), Replacement:=FndList(x, 2), LookAt:=xlPart
Next
End Sub
So as I understand correctly you want a list of phrases translated by a dictionary - word by word. The following script should do it - assuming Sheet1 contains the phrases (in column 1 from row 2) and Sheet2 contains the dictionary(column1 for original values, column2 for translations and also from row2 on). The replaced/translated phrases will appear in column2 of Sheet1.
Firstly, in your original code, vba will take Sheet1 and Sheet2 as two undefined variable automatically, hence there's no alert about this. You should use Worksheets() collection to specify the worksheet.
Secondly, you forgot to change the value of replaceValue. Actually, you can put the cell.value into the replace function as a parameter directly. Therefore there is no need to set a variable for this unless you want to make it more readable.
Lastly, if you want to check whether a word is contained or not. Use InStr function. However in your case, using a replace function is good enough. It will replace the word into the translation you wanted, and will do nothing if there is no match to be found.
Sub btn_Click()
Dim cntPhrases As Integer
Dim cntDict As Integer
Worksheets("Sheet1").Activate
cntPhrases = Worksheets("Sheet1").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count - 1
cntDict = Worksheets("Sheet2").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count - 1
MsgBox (cntPhrases)
Dim i As Integer
Dim j As Integer
Dim phrase As String
Dim org As String
Dim rep As String
For i = 2 To cntPhrases + 1
phrase = Cells(i, 1)
For j = 2 To cntDict + 1
org = Worksheets("Sheet2").Cells(j, 1)
rep = Worksheets("Sheet2").Cells(j, 2)
phrase = replace(phrase, org, rep)
Next j
Cells(i, 2) = phrase
Next i
End Sub
You could also do it like this.
Sub main()
Dim Find_text() As String
Dim Replace_text() As String
Dim str As String
str = "test 150 test 160 test 170 test 200 test 220"
Find_text = Split("150 160 170 180 190 200 210 220")
Replace_text = Split("15 16 17 18 19 20 21 22")
For i = 0 To UBound(Find_text)
For j = 0 To UBound(Replace_text)
If InStr(str, Find_text(j)) > 0 Then
str = Replace(str, Find_text(j), Replace_text(j))
End If
Next
Next
MsgBox str
End Sub
I am trying to run the LinEst function through VBA. The problem that I am having is that my X-variables are in the same column but on different worksheets.
My question: Is it possible to combine these columns from the different sheets to one range?
Below is my attempt to code but it gets stuck on the Union part. I provided my sample as well.
Thank you in advance!
Sub FM()
Dim sResult As Worksheet
Set sResult = Sheets("Result")
Dim sY As Worksheet
Set sY = Sheets("Y")
Dim sX1 As Worksheet
Set sX1 = Sheets("X1")
Dim sX2 As Worksheet
Set sX2 = Sheets("X2")
Dim sX3 As Worksheet
Set sX3 = Sheets("X3")
Dim sX4 As Worksheet
Set sX4 = Sheets("X4")
Dim x() As Variant
ReDim x(1 To 4)
x(1) = sX1.Columns("A")
x(2) = sX2.Columns("A")
x(3) = sX3.Columns("A")
x(4) = sX4.Columns("A")
Dim rY As Range
Set rY = sY.Columns("A")
sResult.Range("B2").Value = Application.WorksheetFunction.LinEst(rY, x, True, True)(1, 4)
End Sub
Sample
In your update, x is an Array of Range objects but it needs to be an array of values from each respective range. That is almost certainly the mismatch error.
Resolving that, you'll need to fix your ranges, too, because it seems unlikely that you're using 4 million rows of data (Excel 2007+ has 1048576 rows per worksheet). We can use a method from this answer to help obtain the last row with data from a given column range.
This should get your x values and put them in an array known_x and the known_y array also, which you can use in your LineEst function.
Dim known_x() 'Will contain all of your x values
Dim known_y()
Dim i As Long
Dim rng As Variant
Dim val As Variant
Dim ws As Variant
Dim obs As Long
Dim SHEET_NAMES As String 'Comma-separated list of worksheets
SHEET_NAMES = "X1,X2,X3,X4"
'## Gets the size of the array needed to contain all of the values
For Each ws In Worksheets(Split(SHEET_NAMES, ","))
With ws
obs = obs + GetLastRow(.Columns(1))
End With
Next
ReDim known_x(1 To obs)
'## Dump the values in to the array
i = 1
For Each ws In Worksheets(Split(SHEET_NAMES, ","))
With ws
Set rng = .Range("A1:A" & GetLastRow(.Columns(1)))
For Each val In rng.Value
known_x(i) = val
i = i + 1
Next
End With
Next
'## Dump your y in to an array
With Worksheets("Sheet2")
Set rng = .Range("A1:A" & GetLastRow(.Columns(1)))
known_y = Application.Transpose(rng.Value))
End With
NOTE: If you are in fact using 4 million+ observations, then I think your known_y's parameter may be wrong, because that should be the same size as known_x's in the LinEst function, and you will need to add logic to ensure the arrays are the same size, etc.
NOTE: I've no idea what you're doing with (1, 4) at the end of your LinEst function call.
I don't want to put a useless answer, but if you play a bit with it, you will find something useful. And it produces some result in B2:
Option Explicit
Sub FM()
Dim sResult As Worksheet
Set sResult = Sheets(1)
Dim sY As Worksheet
Set sY = Sheets(2)
Dim sX1 As Worksheet
Set sX1 = Sheets(3)
Dim sX2 As Worksheet
Set sX2 = Sheets(4)
Dim sX3 As Worksheet
Set sX3 = Sheets(6)
Dim sX4 As Worksheet
Set sX4 = Sheets(5)
Dim x() As Variant
ReDim x(1 To 4)
x(1) = sX1.Cells(1, 1).Value
x(2) = sX1.Cells(2, 1).Value
x(3) = sX1.Cells(3, 1).Value
x(4) = sX1.Cells(4, 1).Value
Dim rY As Range
Set rY = sY.Range(sY.Cells(1, 1), sY.Cells(5, 1))
sResult.Range("B2").Value = Application.WorksheetFunction.LinEst(rY(1, 1), x(1), True, True)
End Sub
The problem is mainly in the way you refer to Arrays and Ranges. Check all of them again and you can make a workable solution.
I am creating a VBA application that will find the text that I have entered in a certain range (Should be dynamic, in order for me to input more in the future). With that the entered texts in the range will look for the words in another sheet column:
Example:
And it will look for the words inputted in another sheet.
Dim Main as Worksheet
Set Main = Sheets("Sheet1")
Dim Raw2 as Worksheet
Set Raw2 = Sheets("Sheet2")
LookFor = Main.Range(D8:100)
Fruits = Raw2.Range("G" & Raw2.Rows.Count).End(xlUp).row
For e = lastRow To 2 Step -1
value = Raw2.Cells(e, 7).value
If Instr(value, LookFor) = 0 _
Then
Raw2.Rows(e).Delete
Honestly I am not sure how to proceed. And the mentioned code is just experiment. Desired output is to delete anything in sheet2 except for the rows that contain the words that I have inputted in the "Look for the words". Hope you can help me. Thank you.
This should do the trick :
Sub Sevpoint()
Dim Main As Worksheet
Set Main = Sheets("Sheet1")
Dim Raw2 As Worksheet
Set Raw2 = Sheets("Sheet2")
Dim LooKFoR() As Variant
Dim LastRow As Double
Dim i As Double
Dim j As Double
Dim ValRow As String
Dim DelRow As Boolean
LooKFoR = Main.Range(Main.Range("G8"), Main.Range("G" & Main.Rows.Count).End(xlUp)).Value
LastRow = Raw2.Range("G" & Raw2.Rows.Count).End(xlUp).Row
For i = LastRow To 2 Step -1
ValRow = Raw2.Cells(i, 7).Value
DelRow = True
'MsgBox UBound(LooKFoR, 1)
For j = LBound(LooKFoR, 1) To UBound(LooKFoR, 1)
If LCase(ValRow)<>LCase(LooKFoR(j, 1)) Then
Else
DelRow = False
Exit For
End If
Next j
If DelRow Then Raw2.Rows(i).Delete
Next i
End Sub