I have an Excel macro, which opens up a template file and saves it under a different name once everything is done.
My VBA loads (Sub Loading) some data from the database to the INPUT sheet. There is another sheet, which uses hlookup table5 to find rows in the INPUT sheet and do some calculations.
I need to extend this Table5 and have the same number of rows as in the INPUT sheet, but it's not working. Do you have any idea how can I achieve that?
StrSQL = "select * from mytable"
Set targetSh = owb.Sheets("INPUT")
Call Loading(targetSh, StrSQL)
Last = targetSh.Cells(Rows.count, "A").End(xlUp).Row
ActiveSheet.Range("Table5").Offset(14, 0).EntireRow.Insert Shift:=xlDown
This will make sure that you have inserted enough rows, that the table is in total with 20:
Sub TestMe()
Dim listObj As ListObject
Set listObj = Worksheets(1).ListObjects("Table5")
With listObj
.Resize listObj.Range.Resize(20)
End With
End Sub
And if you want to insert 20 rows to the rows that the table already has, then first the rows should be saved to a variable rowsTotal. Then, the inserted rows should be equal to rowsTotal+20:
Option Explicit
Sub TestMe()
Dim listObj As ListObject
Dim rowsTotal As Long
Set listObj = Worksheets(1).ListObjects("Table5")
rowsTotal = listObj.Range.Rows.Count
With listObj
.Resize listObj.Range.Resize(rowsTotal + 20)
End With
End Sub
Concerning the insertion of the formulas, you should not worry about it. Excel writes automatically the formula from the previous row on every newly inserted row.
I have solved it using this:
Sub RowsAction(ByRef targetSh As Worksheet, resizeSh As Worksheet, tablename
As String)
Dim i, iLastRow As Integer, oLastRow As ListRow, srcRow As Range
Last = targetSh.Range("A1", targetSh.Cells(Rows.count, "A").End(xlUp)).count - 2
For i = 1 To Last
Set srcRow = resizeSh.ListObjects(tablename).ListRows(i).Range
Set oLastRow = resizeSh.ListObjects(tablename).ListRows.Add
srcRow.Copy
oLastRow.Range.PasteSpecial
Application.CutCopyMode = False
Next
End Sub
Related
In VBA I try to run a loop with an if statement. The loop is set to run a row at a time for a range (wks "Data", B7:J25).
For each row if the value at column C7:C25 is 1, I would like to copy that row (e.g. B7:J7) and insert it at the worksheet "temp" one at a time.
I have tried various codes, for example:
Sub start()
Dim i As Integer
Dim wsData, wsCalcAndOutput, wsTemp As Worksheet
For i = 1 To 25
If Cells((7 + i), 3) = "1" Then
Worksheets("Data").Range("B7:J7").Copy _
Worksheets("temp").Range("B7:J7")
End If
Next
End Sub
But then I can only copy and paste the first row of the range. Alternatively, I found this procedure at stackoverflow, but I can't seem to be able to paste what I copy at each iteration:
Dim wsData, wsCalcAndOutput As Worksheet
Dim rSPX, rSX5E, rNKY, rUKX, rSMI, rEEMUP, testData As Range
Sub start()
Dim i As Integer
For i = 1 To 25
If Cells((7 + i), 3) = "1" Then
With ActiveSheet
.Range(.Cells((7 + i), 2), .Cells((7 + i), 10)).Copy
End With
End If
Next
End Sub
Is this the right way to do so or is there a more efficient way?
Also - in the dataset the criteria for the if statement is actually a string called either "TRUE" or "FALSE". Can an if statement use a string as a signal instead of "1"?
All the best,
Christoffer
As BigBen says, using AutoFilter would be quicker but here is one way of doing this with a loop. Have added a few comments which hopefully explain the basics.
One problem with your code was that you weren't changing the destination cells so they would continually be overwritten.
Sub start()
Dim i As Long 'better than integer
Dim n As Long: n = 7
Dim wsData As Worksheet, wsCalcAndOutput As Worksheet, wsTemp As Worksheet 'specify each type
With Worksheets("Data")
For i = 7 To 25 'change as appropriate
If .Cells(i, 3) = 1 Then 'no need for quotes
Range(.Cells(i, "B"), Cells(i, "J")).Copy _
Worksheets("temp").Cells(n, "B") 'start at row 7?
n = n + 1 'update so that we don't overwrite next time
End If
Next
End With
End Sub
I am new to VBA.
I have 2 sheets under my excel: "Data", "Sheet1".Data sheet is amended every day.
I would like to use vlookup VBA macro to rows added to column A in Sheet1. However my code doesn't give me any results (it works if I run macro under same sheet where data are). Thank you
Private Sub CommandButton21_Click()
On Error Resume Next
Sheet1.Range("B3:D500").Clear
Dim Dept_Row As Long
Dim Dept_Clm As Long
Table1 = Sheet1.Range("A3:A50")
Table2 = Data.Range("A3:H24")
Dept_Row = Sheet1.Range("B3").Row
Dept_Clm1 = Sheet1.Range("B3").Column
Dept_Clm2 = Sheet1.Range("C3").Column
Dept_Clm3 = Sheet1.Range("D3").Column
For Each cl In Table1
Sheet1.Cells(Dept_Row, Dept_Clm1) = Application.WorksheetFunction.VLookup(cl, Table2, 6, False)
Sheet1.Cells(Dept_Row, Dept_Clm2) = Application.WorksheetFunction.VLookup(cl, Table2, 7, False)
Sheet1.Cells(Dept_Row, Dept_Clm3) = Application.WorksheetFunction.VLookup(cl, Table2, 8, False)
Dept_Row = Dept_Row + 1
Next cl
MsgBox "Done"
End Sub
If you are going to code the solution it would be better if you dimension the worksheets as such:
Dim sWS as worksheet 'Source worksheet
dim tWS as worksheet 'Target worksheet
dim aCell as range
with thisworkbook
set sws = .sheets("Data")
set tws = .sheets("Sheet1")
end with
for each acell in sws.range("A3:A50")
with tws
.cells(Dept_Row, Dept_Clm1).value = application....
'also check out the offset function for fetching values in cells to the left or right of the cell you are looping down through.
end with
next acell
Alternatively, check out the Match, Index and Indirect formulas on how to transfer data from one worksheet to another. The three functions are more efficient and accurate than vLookup, especially if you are transferring three cells from one worksheet to another.
I have a table for inputting data and running calculations. This table has a lot of columns, so I create a second table for a printable output. The first column in both tables is a unique value that is common to both tables, so the output table is basically a table that uses lookup functions to pull the required data or results out of the input table for each row.
What is the best way to make the first column in both tables always be identical as the end user adds and deletes rows from the input table? I've been trying to work out a macro so that every time a value is added to the first column of the input the value is copied to the last row of the first column of the output table, but then I don't know how it would work if a row was deleted, or if a duplicate value was added. Or I could use a macro that would copy and paste the entire column every time the input column was changed. Are there any obvious solutions I am missing that I should also be considering? I am pretty new to VBA, but once I figure out which direction would make things easiest for the end user I think I will be able to figure it out.
Update: For anyone else with a similar problem this is the code I ended up writing, it works great so far.
In the worksheet:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A:A")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Call Module1.UpdateOutput
End If
End Sub
In Module 1:
Sub UpdateOutput()
' UpdateOutput Macro
'Set active cell for return at end of macro
Dim ActCell As Range
Set ActCell = Selection
' Check Input table has data
If Sheet6.ListObjects("Input").DataBodyRange Is Nothing Then
Exit Sub
End If
'Count Selected Rows of Input and Output Table
Dim RowsIn As Long
RowsIn = Sheet6.ListObjects("Input").ListColumns("UWI").DataBodyRange.Rows.Count
Dim RowsOut As Long
RowsOut = Sheet3.ListObjects("Results").DataBodyRange.Rows.Count
Dim RowsCalc As Long
RowsCalc = Sheet1.ListObjects("IWCP").DataBodyRange.Rows.Count
Application.ScreenUpdating = False
'Delete extra rows from Output Table
Dim lRow As Long
lRow = RowsOut + 1
Do While lRow >= RowsIn + 2
Sheet3.Rows(lRow).Delete
Sheet1.Rows(lRow + 1).Delete
lRow = lRow - 1
Loop
'Select UWI column from input table
Application.Goto Sheet6.ListObjects("Input").ListColumns("UWI").DataBodyRange
Selection.Copy
'Paste UWI column from input table
Sheet3.ListObjects("Results").ListColumns("UWI").DataBodyRange(1).PasteSpecial xlPasteValues
Sheet1.ListObjects("IWCP").ListColumns("UWI").DataBodyRange(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Return to previous cell
Application.Goto ActCell
Application.ScreenUpdating = True
End Sub
I am assuming both of your tables are in Sheet1. You have to insert in the module corresponding to Sheet1 the following code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngsrc As Range, rngtrg As Range
Dim losrc As ListObject, lotrg As ListObject
Set losrc = Me.ListObjects(1)
Set lotrg = Me.ListObjects(2)
'Set rngsrc = your_source_range_to_monitor
Set rngsrc = losrc.ListColumns(1).Range
Set rngtrg = lotrg.ListColumns(1).Range
Dim ints As Range
Set ints = Application.Intersect(rngsrc, Target)
If (Not (ints Is Nothing)) Then
' Do your job to copy from rngsrc to rngtrg
Application.CutCopyMode = xlCopy
rngsrc.Copy
rngtrg.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlPasteSpecialOperationNone
End If
End Sub
and modify as needed.
i'm trying to make a macro which:
goes through a table
looks if value in column B of that table has a certain value
if it has, copy that row to a range in an other worksheet
The result is similar to filtering the table but I want to avoid hiding any rows
I'm kinda new to vba and don't really know where to start with this, any help much appreciated.
That is exactly what you do with an advanced filter. If it's a one shot, you don't even need a macro, it is available in the Data menu.
Sheets("Sheet1").Range("A1:D17").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("G1:G2"), CopyToRange:=Range("A1:D1") _
, Unique:=False
Try it like this:
Sub testIt()
Dim r As Long, endRow as Long, pasteRowIndex As Long
endRow = 10 ' of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 1 To endRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("B").Column).Value = "YourCriteria" Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
End Sub
Selects are slow and unnescsaary. The following code will be far faster:
Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
For i = 2 To ws1.Range("B65536").End(xlUp).Row
If ws1.Cells(i, 2) = "Your Critera" Then ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
Next i
End Sub
you are describing a Problem, which I would try to solve with the VLOOKUP function rather than using VBA.
You should always consider a non-vba solution first.
Here are some application examples of VLOOKUP (or SVERWEIS in German, as i know it):
http://www.youtube.com/watch?v=RCLUM0UMLXo
http://office.microsoft.com/en-us/excel-help/vlookup-HP005209335.aspx
If you have to make it as a macro, you could use VLOOKUP as an application function - a quick solution with slow performance - or you will have to make a simillar function yourself.
If it has to be the latter, then there is need for more details on your specification, regarding performance questions.
You could copy any range to an array, loop through this array and check for your value, then copy this value to any other range. This is how i would solve this as a vba-function.
This would look something like that:
Public Sub CopyFilter()
Dim wks As Worksheet
Dim avarTemp() As Variant
'go through each worksheet
For Each wks In ThisWorkbook.Worksheets
avarTemp = wks.UsedRange
For i = LBound(avarTemp, 1) To UBound(avarTemp, 1)
'check in the first column in each row
If avarTemp(i, LBound(avarTemp, 2)) = "XYZ" Then
'copy cell
targetWks.Cells(1, 1) = avarTemp(i, LBound(avarTemp, 2))
End If
Next i
Next wks
End Sub
Ok, now i have something nice which could come in handy for myself:
Public Function FILTER(ByRef rng As Range, ByRef lngIndex As Long) As Variant
Dim avarTemp() As Variant
Dim avarResult() As Variant
Dim i As Long
avarTemp = rng
ReDim avarResult(0)
For i = LBound(avarTemp, 1) To UBound(avarTemp, 1)
If avarTemp(i, 1) = "active" Then
avarResult(UBound(avarResult)) = avarTemp(i, lngIndex)
'expand our result array
ReDim Preserve avarResult(UBound(avarResult) + 1)
End If
Next i
FILTER = avarResult
End Function
You can use it in your Worksheet like this =FILTER(Tabelle1!A:C;2) or with =INDEX(FILTER(Tabelle1!A:C;2);3) to specify the result row. I am sure someone could extend this to include the index functionality into FILTER or knows how to return a range like object - maybe I could too, but not today ;)
I'm just beginning to dive into VBA and I've hit a bit of a roadblock.
I have a sheet with 50+ columns, 900+ rows of data. I need to reformat about 10 of those columns and stick them in a new workbook.
How do I programmatically select every non-blank cell in a column of book1, run it through some functions, and drop the results in book2?
I know I'm am very late on this, but here some usefull samples:
'select the used cells in column 3 of worksheet wks
wks.columns(3).SpecialCells(xlCellTypeConstants).Select
or
'change all formulas in col 3 to values
with sheet1.columns(3).SpecialCells(xlCellTypeFormulas)
.value = .value
end with
To find the last used row in column, never rely on LastCell, which is unreliable (it is not reset after deleting data). Instead, I use someting like
lngLast = cells(rows.count,3).end(xlUp).row
The following VBA code should get you started. It will copy all of the data in the original workbook to a new workbook, but it will have added 1 to each value, and all blank cells will have been ignored.
Option Explicit
Public Sub exportDataToNewBook()
Dim rowIndex As Integer
Dim colIndex As Integer
Dim dataRange As Range
Dim thisBook As Workbook
Dim newBook As Workbook
Dim newRow As Integer
Dim temp
'// set your data range here
Set dataRange = Sheet1.Range("A1:B100")
'// create a new workbook
Set newBook = Excel.Workbooks.Add
'// loop through the data in book1, one column at a time
For colIndex = 1 To dataRange.Columns.Count
newRow = 0
For rowIndex = 1 To dataRange.Rows.Count
With dataRange.Cells(rowIndex, colIndex)
'// ignore empty cells
If .value <> "" Then
newRow = newRow + 1
temp = doSomethingWith(.value)
newBook.ActiveSheet.Cells(newRow, colIndex).value = temp
End If
End With
Next rowIndex
Next colIndex
End Sub
Private Function doSomethingWith(aValue)
'// This is where you would compute a different value
'// for use in the new workbook
'// In this example, I simply add one to it.
aValue = aValue + 1
doSomethingWith = aValue
End Function
If you are looking for the last row of a column, use:
Sub SelectFirstColumn()
SelectEntireColumn (1)
End Sub
Sub SelectSecondColumn()
SelectEntireColumn (2)
End Sub
Sub SelectEntireColumn(columnNumber)
Dim LastRow
Sheets("sheet1").Select
LastRow = ActiveSheet.Columns(columnNumber).SpecialCells(xlLastCell).Row
ActiveSheet.Range(Cells(1, columnNumber), Cells(LastRow, columnNumber)).Select
End Sub
Other commands you will need to get familiar with are copy and paste commands:
Sub CopyOneToTwo()
SelectEntireColumn (1)
Selection.Copy
Sheets("sheet1").Select
ActiveSheet.Range("B1").PasteSpecial Paste:=xlPasteValues
End Sub
Finally, you can reference worksheets in other workbooks by using the following syntax:
Dim book2
Set book2 = Workbooks.Open("C:\book2.xls")
book2.Worksheets("sheet1")
For me the best way to proceed was to:
Create a new Excel Table
AutoFilter it by the parameter Criterial:="<>"
An example of the code would be:
Sub ExampleFilterCol()
' Create a Table
Dim ws As Worksheet
Dim rg As Range
Set ws = ActiveSheet
Set rg = ws.Range("A1").CurrentRegion
ws.ListObjects.Add(xlSrcRange, rg, , xlYes).Name = "myNonRepeatedTableName"
' Filter the created table
Dim Io As ListObject
Dim iCol As Long
' Set reference to the first Table on the sheet
' That should be the recently created one
Set lo = Sheets("Totalinfo").ListObjects(1)
' Set filter field
iCol = lo.ListColumns("yourColumnNameToFilter").Index
' Non-blank cells – use NOT operator <>
lo.Range.AutoFilter Field:=iCol, Criteria1:="<>"
End Sub
This might be completely off base, but can't you just copy the whole column into a new spreadsheet and then sort the column? I'm assuming that you don't need to maintain the order integrity.