I have a VBA code that copies and pastes pages and copies everything properly except any cell that has a vlookup. I don't know what the problem is or if there may be some lag time. Any ideas would be helpful.
Dim thisSheet As Worksheet
Set thisSheet = Application.ActiveSheet
Dim templateSheet As Worksheet
Set templateSheet = Worksheets("Template ")
Dim baseSheet As Worksheet
Set baseSheet = Worksheets("Base")
Dim wrkBook As Workbook
Set wrkBook = ActiveSheet.Parent
Dim wrkSheet As Worksheet
Dim sNewSheetName As String
Dim nRow As Integer
Application.ScreenUpdating = False
Dim rRunRange As Range
Set rRunRange = Range("Cohorts_to_Run")
Dim n As Integer
For nRow = 1 To rRunRange.Rows.Count
sNewSheetName = rRunRange.Cells(nRow, 2).Value
Set wrkSheet = Worksheets.Add(, Worksheets(Worksheets.Count))
wrkSheet.Name = sNewSheetName
'Set parameters to pickup data....
Dim zZoom As Double
zZoom = ActiveWindow.Zoom
templateSheet.Activate
templateSheet.Range(baseSheet.Range("TEMPLATE_COPY_RANGE").Value).Copy
wrkSheet.Activate
wrkSheet.PasteSpecial xlPasteColumnWidths
wrkSheet.Paste
ActiveWindow.Zoom = baseSheet.Range("ZOOM_LEVEL").Value
wrkSheet.Range("A1").RowHeight = 10
Application.CutCopyMode = False
wrkSheet.Range("B2").Value = Range("Cohorts_to_Run").Cells(nRow, 1).Value
Dim sTitleRangeName As String
sTitleRangeName = sNewSheetName & "_Title"
wrkSheet.Range(baseSheet.Range("TEMPLATE_COPY_RANGE").Value).Select
Selection.Copy
wrkSheet.Range(baseSheet.Range("TEMPLATE_COPY_RANGE").Value).PasteSpecial
xlPasteValuesAndNumberFormats
Next nRow
I assume your confusion is that last line which pastes only values and removes any formulas.
wrkSheet.Range(baseSheet.Range("TEMPLATE_COPY_RANGE").Value).PasteSpecial xlPasteValuesAndNumberFormats
Why not just paste? xlPasteValuesAndNumberFormats will remove your formulas everytime. That's the point.
Dim copyRange as Range, pasteRange as Range
Set copyRange = wrkSheet.Range(baseSheet.Range("TEMPLATE_COPY_RANGE").Value)
Set pasteRange = wrkSheet.Range(baseSheet.Range("TEMPLATE_COPY_RANGE").Value)
copyRange.Copy pasteRange
You're wrkSheet.Range(baseSheet.Range("TEMPLATE_COPY_RANGE").Value) syntax is confusing though. Is there the name of another range in your named range TEMPLATE_COPY_RANGE?
Related
I'm trying to use vlookup() function under for loop condition, but the value only follow only the first row value. This is my code. Sorry, the code is quite messy; I'm still learning VBA.
Sub vlookup_Click()
Application.ScreenUpdating = False
Dim result As String
Dim i As Long
Dim iLast As Long
Dim result1 As String
Dim sheet As Worksheet
Dim sheet1 As Worksheet
Dim WrkSht As String
WrkSht = "Sheet1"
iLast = ActiveWorkbook.Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set sheet = ActiveWorkbook.Sheets("Sheet1")
Set sheet1 = ActiveWorkbook.Sheets("InventoryReport")
For i = 10 To iLast
result = Application.WorksheetFunction.VLookup(sheet.Range("$B$10"), _
sheet1.Range("$B$10:$Q$48"), 16, False)
Sheets(WrkSht).Cells(i, 9).Value = result
Next i
End Sub
Below picture shows the result.Any idea to solve this?
Expected and Current Result:
So let's consider dumping the VLOOKUP() option. We are using VBA, so we have more power when it comes to looking up ranges.
I think we should go with using the range.Find() method here. Set this object, use the Row() property to match the Q column on that range, and return it to your I column in ws1.
Try this
Sub vlookup_Click()
Application.ScreenUpdating = False
Dim i As Long
Dim iLast As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim findRng As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("InventoryReport")
'Changed ActiveWorksheet to ws1 for your iLast
iLast = ws1.Range("A" & Rows.Count).End(xlUp).Row
For i = 10 To iLast
Set findRng = ws2.Range("B:B").Find(ws1.Cells(i, "B"), , xlValues, xlWhole)
If Not findRng Is Nothing Then
ws1.Cells(i, "I") = ws2.Cells(findRng.Row, "Q")
Else
ws1.Cells(i, "I") = 0
End If
Set findRng = Nothing
Next i
Application.ScreenUpdating = True
End Sub
I see you use the excel worksheet function, but use the form of formulaR1C1 will be better. And record the Macro will free you from calculate the row# for the formula.
how to do:
You can just video this operation to get that code in your excel by click Tab "Developer" in your
excel/"record Macro" then input the formular in the cell then "stop recording" then Alt+F11 to get to
access the code of the vlookup formula:
ActiveCell.FormulaR1C1 = "=VLOOKUP(R10C2,R[3]C[-1]:R[41]C[11],16,0)"
I made a Data Entry Form that ads or updates rows in a datasheet. With this http://www.contextures.com/exceldataentryupdateform.html as the base. The form has 128 rows and 5 of those are vlookup formulas (row 12, 19, 30, 34, 36) that should be excluded when using the view record navigation buttons. Otherwise the formulas get deleted and replaced by a value, if you use the nav buttons.
But I really have no clue how to do this. I'm really new to VBA. This is my first project so all help will be greatly appreciated.
Sub ViewLogDown()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim rngA As Range
Dim lRec As Long
Dim lRecRow As Long
Dim lLastRec As Long
Dim lastRow As Long
Application.EnableEvents = False
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("Werknemers")
Set rngA = ActiveCell
With historyWks
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
lLastRec = lastRow - 1
End With
With inputWks
lRec = .Range("CurrRec").Value
If lRec < lLastRec Then
.Range("CurrRec").Value = lRec + 1
lRec = .Range("CurrRec").Value
lRecRow = lRec + 1
historyWks.Range(historyWks.Cells(lRecRow, 3), historyWks.Cells(lRecRow, 128)).Copy
.Range("D5").PasteSpecial Paste:=xlPasteValues, Transpose:=True
inputWks.Range("OrderSel").Value = .Range("D5").Value
rngA.Select
End If
End With
Application.EnableEvents = True
End Sub
If you want to copy and paste and exclude formula-based cells then you can use the SpecialCells method of the Range object. `xlCellTypeConstants' will filter out cells without a formula and blank cells.
E.g. with your code:
Dim rngSource As Range
Dim rngFilter As Range
Set rngSource = historyWks.Range(historyWks.Cells(lRecRow, 3), historyWks.Cells(lRecRow, 128))
Set rngFilter = rngSource.SpecialCells(xlCellTypeConstants)
Note once pasted the Range will be smaller than the original because the cells with formulas are discounted.
You can Union different calls SpecialCells together. So to include blanks you could use:
Dim rngSource As Range
Dim rngFilter As Range
Set rngSource = historyWks.Range(historyWks.Cells(lRecRow, 3), historyWks.Cells(lRecRow, 128))
Set rngFilter = Union( _
rngSource.SpecialCells(xlCellTypeConstants), _
rngSource.SpecialCells(xlCellTypeBlanks) _
)
Sample code for minimal example of use of SpecialCells:
Option Explicit
Sub TestRangeCopyExcludingFormulas()
Dim ws As Worksheet
Dim rngToCopy As Range
Dim rngToCopyExcludingFormulas As Range
Dim rngToPaste As Range
Dim rngCell As Range
' set the worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
' set the range to copy excluding formulas
Set rngToCopy = ws.Range("B3:B13")
' copy just the constants
' Set rngToCopyExcludingFormulas = rngToCopy.SpecialCells(xlCellTypeConstants)
' copy constants and blanks
Set rngToCopyExcludingFormulas = Union( _
rngToCopy.SpecialCells(xlCellTypeConstants), _
rngToCopy.SpecialCells(xlCellTypeBlanks))
' set the range to paste to
Set rngToPaste = ws.Range("E3")
' do the copy and paste
rngToCopyExcludingFormulas.Copy
rngToPaste.PasteSpecial Paste:=xlPasteValues
' use transpose etc
' rngToPaste.PasteSpecial Paste:=xlPasteValues, Transpose:=True
' remove the dancing ants
Application.CutCopyMode = False
End Sub
See screenshot:
I have a list of accounts & codes, and would like to populate a column with results from a different sheet using index match. I can get it to work using the formula: =index(rngB,match(BCode,rngM,0),55)
but can't translate it to vba. I have tried:
sub compare()
Dim BudgetResult As Long
Dim var1 As Long
Dim rngB, rngM As Range
Dim CompSH, ActSH, BudSH As Worksheet
Dim BCode As Variant
Set CompSH = Sheets.Add(After:=Sheets(Sheets.Count))
Set ActSH = Sheets(2)
Set BudSH = Sheets(3)
Set rngB = BudSH.Range("B11:BF50")
Set rngM = BudSH.Range("B:B")
Set BCode = CompSH.Range("A2")
BudSH.Select
Range("B10:E76").Select
Selection.Copy
CompSH.Select
ActiveSheet.Paste
Range("F1").Select
ActiveCell.FormulaR1C1 = "Budget"
Range("F2").Select
With Application.WorksheetFunction
var1 = .Match(BCode, rngM, 0)
BudgetResult = .Index(rngB, var1, 55)
End With
I get a blank cell. no result in the sheet.
Also, I don't know how to continue it down. Can anyone help?
you may be after something like follows
Option Explicit
Sub compare()
Dim rngB As Range, rngM As Range, cell As Range
Dim CompSH As Worksheet, ActSH As Worksheet, BudSH As Worksheet
Dim AW As WorksheetFunction: Set AW = Application.WorksheetFunction
Set CompSH = Sheets.Add(After:=Sheets(Sheets.count))
Set ActSH = Sheets("ActSH") 'Sheets(2)
Set BudSH = Sheets("BudSH") 'Sheets(3)
With BudSH
Set rngB = .Range("B11:BF50") '<--| warning: your "index" range has 40 rows
Set rngM = .Range("B:B")
.Range("F1").Value = "Budget"
.Range("B10:E76").Copy CompSH.Range("A1") '<--| warning: your "copied" range has 67 rows
End With
With CompSH
For Each cell In .Range("A2", .Cells(.Rows.count, 1).End(xlUp))
cell.Offset(, 5).Value = AW.Index(rngB, AW.Match(cell, rngM, 0), 55) '<--| this will error when trying to access from 'rngB' range 41th rows on
Next
End With
End Sub
where you only have to adjust the range sizes in the statements marked with <--| Warning...
I need to copy the same worksheet X times (x = sheet2 row A) into a new workbook.
For each copy I need to:
1.Change a drop down to display the next value
2.Do a Refresh (Workbook is connected to a database which pulls different information based on the value of the drop down and is not automatically refreshed)
3.Copy just the values (no formulas)
Rename the sheet to the value of the drop down.
Save all of the copied worksheets into 1 workbook
My code (below) which is called on a button press currently saves the sheet X times based on sheet2 rowA (as intended).
It is missing steps 1,2,4 and 5
The code I have at the moment (called on button click)
Dim x As Integer '~~>Loop counter
Dim WS As Worksheet
Dim LastCellA As Range, LastCellB As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Sheet2") '~~>Sheet with names
With WS
Set LastCellA = .Cells(.Rows.Count, "A").End(xlUp) '~~>Column with names.
'~~>This needs to be changed to find the range as data may not start at A1
x = Application.WorksheetFunction.Max(LastCellA.Row)
End With
For numtimes = 1 To x
ActiveWorkbook.Sheets("Sheet1").Copy _
After:=ActiveWorkbook.Sheets(Worksheets.Count)
'~~>Copy values only
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Next
Still... I'm not sure of the point that you "Import" different values based on a drop down. That may be a different macro for loding the data. Then you need to call that macro instead of the .RefreshAll.
Sub test()
Dim uRow As Long, lRow As Long, i As Long
Dim wb As Workbook, ws As Object
With ThisWorkbook
Set ws = .Sheets("Sheet2")
With ws
uRow = .Cells(.Rows.Count, "A").End(xlUp).End(xlUp).Row
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set wb = Workbooks.Add
For i = uRow To lRow
.Sheets("Sheet1").Range("M1").Value = ws.Cells(i, 1).Value '<~~~ this should change the dropdown
Calculate
.RefreshAll
.Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
Next
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
For Each ws In wb.Sheets
ws.UsedRange.Value = ws.UsedRange.Value
Next
End With
End Sub
EDIT:
If you get trouble with the Sheet2 Column A List (cus it contains empty cells resulting of formulas) you may try a different approach:
Sub test()
Dim wb As Workbook, ws As Worksheet
Dim xVal As Variant
With ThisWorkbook
Set ws = .Sheets("Sheet2")
Set wb = Workbooks.Add
For Each xVal In Intersect(ws.Range("A:A"), ws.UsedRange).Value
If Len(xVal) Then
.Sheets("Sheet1").Range("M1").Value = xVal
Calculate
.RefreshAll
.Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
wb.Sheets(wb.Sheets.Count).UsedRange.Value = wb.Sheets(wb.Sheets.Count).UsedRange.Value
End If
Next
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
End With
End Sub
Based on the code you provided, I believe this is what you are looking for.
It will loop through your list, copy sheet1 to the new workbook and name the sheet.
I am not sure what you want with looping through your dropdown list.
Sub Button1_Click()
Dim wb As Workbook, Bk As Workbook
Dim WS As Worksheet, sh As Worksheet
Dim LastCellA As Long, LastCellB As Range, c As Range
Dim LastCellRowNumber As Long
Dim x As Integer '~~>Loop counter
Set wb = ThisWorkbook
Set WS = wb.Worksheets("Sheet2") '~~>Sheet with names
Set sh = wb.Sheets("Sheet1")
With WS
LastCellA = .Cells(.Rows.Count, "A").End(xlUp).Row '~~>Column with names.
'~~>This needs to be changed to find the range as data may not start at A1
Set LastCellB = .Range("A1:A" & LastCellA).SpecialCells(xlCellTypeConstants, 23)
End With
Set Bk = Workbooks.Add
For Each c In LastCellB.Cells
sh.Range("M1") = c
sh.Copy After:=Bk.Sheets(Worksheets.Count)
With ActiveSheet
'~~>Copy values only
.UsedRange.Value = .UsedRange.Value
.Name = c
End With
Next c
End Sub
I'm a portuguese engineer and I've recently started programming in Visual Basic on a button from a specific Worksheet named "Início" on a Workbook named by "Livro MQTEN". On the Worksheet "Início" I have one button with the following code:
Private Sub CommandButton1_Click()
Dim lngCount As Long
Dim j As String
Dim fileName As String
Dim lngIndex As Long
Dim strPath() As String
Dim nome As String
Dim folha As String
' Open the file dialog
With Application.FileDialog(msoFileDialogOpen)
.Title = "Selecione o ficheiro dos comboios realizados do dia"
.InitialFileName = "Explor. *"
.AllowMultiSelect = False
.Show
.Filters.Add "Excel files", "*.xlsx; *.xls", 1
' Display paths of each file selected
For lngCount = 1 To .SelectedItems.Count
'MsgBox .SelectedItems(lngCount)
j = .SelectedItems(lngCount)
'MsgBox (j)
strPath() = Split(j, "\") 'Put the Parts of our path into an array
lngIndex = UBound(strPath)
fileName = strPath(lngIndex) 'Get the File Name from our array
'MsgBox (fileName)
nome = fileName
'Get name of sheet
Dim wb As Workbook
Dim ws As Worksheet
Dim TxtRng As Range
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Início")
ws.Unprotect
Set TxtRng = ws.Range("D17")
TxtRng.Value = nome
ws.Protect
folha = Cells.Item(21, 6)
'MsgBox (folha)
'Copy from sheet
Dim x As Workbook, y As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim SrcRange As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set x = Workbooks.Open(j)
Set y = ThisWorkbook
Set ws1 = x.Sheets(folha)
Set ws2 = y.Sheets("Explor. do Mês")
Set CopyData = ws1.Range("A1:M8000").EntireColumn
CopyData.Copy
Set Addme = ws2.Range("A1:M8000")
Addme.PasteSpecial xlPasteValues
x.Close True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Next lngCount
End With
End Sub
In the code:
Set CopyData = ws1.Range("A1:M8000").EntireColumn
CopyData.Copy
Set Addme = ws2.Range("A1:M8000")
Addme.PasteSpecial xlPasteValues
I paste the entire column from column A to column M. I need to Copy and PasteSpecial only the cells from the worksheet ws1 that have values to the worksheet ws2. Then if I click again in the button and select another Workbook add the values to ws2 and not overwrite them. How can I do this in Visual Basic? What I'm missing here? Please guys, I really, really need your help! Thanks in advance.
SOLVED!
Just changed the code above to:
With ws2
'Presuming the column "A" in ws2 will always contain the last row.
intLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'Presuming we will ALWAYS copy the "A1:M8000" range, and that the column "A" is filled.
'Because we determine the last used row based on this column in ws2 (intLastRow)
ws1.Range("A1:M8000").Copy
.Cells(intLastRow + 1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
And added in the variables declaration this:
Dim intLastRow As Integer
Change the copy code with this :
Dim intLastRow As Integer 'put it where you declare variables.
'Maybe use long, if data on ws2 can exceed 32K rows or something like that.
With ws2
'Presuming the column "A" in ws2 will always contain the last row.
intLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'Presuming we will ALWAYS copy the "A1:M8000" range, and that the column "A" is filled.
'Because we determine the last used row based on this column in ws2 (intLastRow)
.Range(.Cells(intLastRow + 1, 1), .Cells(intLastRow + 1, 13)) = ws1.Range("A1:M8000").Value
End With
Edit 1
Ammended the code based on comment from OP. Now with the correct Range("A1:M8000") and Cells(intLastRow + 1, 13)
Edit 2
With ws2
'Presuming the column "A" in ws2 will always contain the last row.
intLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'Presuming we will ALWAYS copy the "A1:M8000" range, and that the column "A" is filled.
'Because we determine the last used row based on this column in ws2 (intLastRow)
ws1.Range("A1:M8000").Copy
.Cells(intLastRow + 1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
You can try to use "For" method to read each cells individually
The code below will copy from sheet1 only if the cell is not empty and will only paste if the cell in sheet2 is not filled
'this one will run each row
For i = 1 to 8000
'this one will run each collumn
For j = 1 to 13
If ws1.cells(i,j) <> "" then
ws1.cells(i,j).copy
if ws2.cells(i,j) = "" then
ws2.cells(i,j).PasteSpecial xlPasteValues
Else:
cutcopymode=false
End if
End if
Next
Next