I am trying to create user form (like on picture) from where I would choose 2 excel files and execute Vlookup. I
I try this code but it does not execute Vlookup.
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Option Explicit
Dim FileToOpen1 As Variant
Dim FileToOpen2 As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim cl As Range
Private Sub BrowseButton1_Click()
FileToOpen1 = Application.GetOpenFilename(Title:="Browse for your file", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen1 <> False Then
TextBox1 = FileToOpen1
End If
End Sub
Private Sub BrowseButton2_Click()
FileToOpen2 = Application.GetOpenFilename(Title:="Browse foy your file", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen2 <> False Then
TextBox2 = FileToOpen2
End If
End Sub
Private Sub OK_Click()
If FileToOpen1 <> False Then
Set wb1 = Application.Workbooks.Open(FileToOpen1)
End If
If FileToOpen2 <> False Then
Set wb2 = Application.Workbooks.Open(FileToOpen2)
End If
On Error Resume Next
rng1 = wb1.Sheets(1).Range("B3:B8")
Price_row = wb1.Sheets(1).Range("C3").row
Price_clm = wb1.Sheets(1).Range("C3").column
rng2 = wb2.Sheets(1).Range("A3:C8")
For Each cl In rng1
wb1.Sheets(1).Cells(Price_row, Price_clm) = Application.WorksheetFunction.VLOOKUP(cl, rng2, 2, False)
Price_row = Price_row + 1
Next cl
End Sub
You are missing two variable definitions:
Dim Price_row As Long
Dim Price_clm As Long
And variables for range need to be assigned with Set
This: Set rng2 = wb2.Sheets(1).Range("A3:C8") instead of this rng2 = wb2.Sheets(1).Range("A3:C8")
Now, vlookup function in vba will throw an error when it doesnt find a value.
A workaround for this will be something like this.
Private Sub OK_Click()
If FileToOpen1 <> False Then
Set wb1 = Application.Workbooks.Open(FileToOpen1)
End If
If FileToOpen2 <> False Then
Set wb2 = Application.Workbooks.Open(FileToOpen2)
End If
Set rng1 = wb1.Sheets(1).Range("B3:B8")
Price_row = wb1.Sheets(1).Range("C3").Row
Price_clm = wb1.Sheets(1).Range("C3").Column
Set rng2 = wb2.Sheets(1).Range("A3:C8")
For Each cl In rng1
On Error Resume Next
vlResult = "" 'Reset variable
vlResult = Application.WorksheetFunction.VLookup(cl, rng2, 2, False) 'Performs vlookup
If Not vlResult = "" Then
wb1.Sheets(1).Cells(Price_row, Price_clm).Value = vlResult
Else
wb1.Sheets(1).Cells(Price_row, Price_clm).Value = "N/A"
End If
Price_row = Price_row + 1
Next cl
End Sub
*Dont forget to add the variable too.
Dim vlResult As String
Related
The below code copies data from multiple worksheets and consolidates into database (database worksheet). I am trying to add a new column at the last unused column of database worksheet that gives the name of the sheets in each row, the data is copied from with the column header as "Sheet Name". The problem is, I am trying to start with adding the header by using wsData.Range(1, wsData.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)).Value = "SheetName", but unfortunately, it is giving an error.
The program is currently taking 6 minutes to process around 25,000 rows, so is there a way to make it faster?
I am not very well-versed with VBA and I received the below code from another stack overflow question. Below is my code. Any help will be appreciated.
Sub ProcessWorkbooks()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim f, wsData As Worksheet, wbSrc As Workbook, map As Object
Set wsData = ThisWorkbook.Sheets("Database")
wsData.UsedRange.ClearContents 'clear any existing data
Dim fldr1 As FileDialog
Dim iFile As String
Set fldr1 = Application.FileDialog(msoFileDialogFolderPicker)
With fldr1
.Title = "Select InputFile Folder... "
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show = -1 Then
iFile = .SelectedItems(1)
Else
Exit Sub
End If
End With
Dim strPath As String
strPath = iFile
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(strPath)
Dim abc As Boolean
abc = False
For Each oFile In oFolder.Files
If oFile.Name Like "*xls*" Then
Set wbSrc = Workbooks.Open(oFolder & "\" & oFile.Name)
ImportData wbSrc, wsData, abc
wbSrc.Close False
End If
Next oFile
With wsData.Range("A1").CurrentRegion
.Font.Size = 9
.Font.Name = "Calibri"
.Borders.LineStyle = xlLineStyleNone
.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox Title:="Task Box", Prompt:="Database Created!"
End Sub
Sub ImportData(wbIn As Workbook, wsData As Worksheet, abc as Boolean)
Dim lrData As Long, lrSrc As Long, ws As Worksheet, c As Range
Dim Process, hdr, m, n
Process = Array("Manila", "Cebu", "Davao", "CDO", "Bacolod")
Application.ScreenUpdating = False
For Each ws In wbIn.Worksheets
Call KillFilter
n = ws.Name
lrData = wsData.Cells(Rows.Count, "A").End(xlUp).Row + 1
'lrData = SheetLastRow(wsData) + 1
If lrData = 1 Then lrData = 2 'in case no headers yet...
lrSrc = SheetLastRow(ws)
For Each c In ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Cells
hdr = c.Value
m = Application.Match(hdr, wsData.Rows(1), 0) 'existing column match?
If IsError(m) Then
m = Application.CountA(wsData.Rows(1))
m = IIf(m = 0, 1, m + 1)
wsData.Cells(1, m).Value = hdr 'add as new column header
End If
ws.Range(c.Offset(1), ws.Cells(lrSrc, c.Column)).Copy _
wsData.Cells(lrData, m)
Next c
If abc = False Then
wsData.Range(1, wsData.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)).Value = "SheetName"
abc = True
End If
Next ws
End Sub
'return the last used row in a worksheet
Function SheetLastRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious)
If Not f Is Nothing Then SheetLastRow = f.Row 'otherwise 0
End Function
See below for how to add the sheet name, and some other suggestions:
Option Explicit
Sub ProcessWorkbooks()
Dim f, wsData As Worksheet, wbSrc As Workbook, map As Object, strPath As String
Dim oFSO As Object, oFile As Object, nextRow As Long
On Error GoTo haveError 'ensures event/calc settings are restored
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
strPath = ChooseFolder("Select InputFile Folder... ") 'made this a new Function
If Len(strPath) = 0 Then Exit Sub
Set wsData = ThisWorkbook.Sheets("Database")
With wsData
.UsedRange.ClearContents 'clear any existing data
.Range("A1").value = "Sheet Name" 'add the sheet name header
End With
Set oFSO = CreateObject("Scripting.FileSystemObject")
For Each oFile In oFSO.getfolder(strPath).Files
If oFile.name Like "*.xls*" Then
Set wbSrc = Workbooks.Open(oFile.Path)
ImportData wbSrc, wsData
wbSrc.Close False
End If
Next oFile
With wsData.Range("A1").CurrentRegion
.Font.Size = 9
.Font.name = "Calibri"
.Borders.LineStyle = xlLineStyleNone
.EntireColumn.AutoFit
End With
haveError:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox Title:="Task Box", Prompt:="Database Created!"
End Sub
'assumes there's always a "sheet Name" header in A1 of wsData
Sub ImportData(wbIn As Workbook, wsData As Worksheet)
Dim lrData As Long, lrSrc As Long, ws As Worksheet, c As Range
Dim Process, hdr, m
Process = Array("Manila", "Cebu", "Davao", "CDO", "Bacolod") '????
For Each ws In wbIn.Worksheets
If ws.FilterMode Then ws.ShowAllData 'remove any filtering
lrData = wsData.Cells(Rows.Count, "A").End(xlUp).Row + 1 'paste row
lrSrc = SheetLastRow(ws)
wsData.Cells(lrData, "A").Resize(lrSrc - 1).value = ws.name '<<< add the sheet name....
For Each c In ws.Range("A1", ws.Cells(1, ws.Columns.Count).End(xlToLeft)).Cells
hdr = c.value
m = Application.Match(hdr, wsData.Rows(1), 0) 'existing column match?
If IsError(m) Then 'need to add this header?
m = wsData.Cells(1, Columns.Count).End(xlToLeft).Column + 1
wsData.Cells(1, m).value = hdr
End If
ws.Range(c.Offset(1), ws.Cells(lrSrc, c.Column)).Copy _
wsData.Cells(lrData, m)
Next c
Next ws
End Sub
'Ask user to select a folder. Returns empty string if none selected
Function ChooseFolder(prmpt As String) As String
Dim fldr1 As FileDialog, fldr As String
Dim iFile As String
Set fldr1 = Application.FileDialog(msoFileDialogFolderPicker)
With fldr1
.Title = prmpt
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show = -1 Then ChooseFolder = .SelectedItems(1)
End With
End Function
'return the last used row in a worksheet
Function SheetLastRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious)
If Not f Is Nothing Then SheetLastRow = f.Row 'otherwise 0
End Function
I want to extract a range from values in cells in excel. with this code i get a error every time, but not when i put the row and column index numbers manually. This is the code:
Sub Checker()
With Application
.DisplayAlerts = False
.EnableEvents = False
End With
Dim folderpath As String
Dim workbookname As String
Dim filepath As String
folderpath = Range("B3").Value
workbookname = Range("B6").Value
filepath = folderpath + workbookname
Workbooks.Open Filename:=filepath
Range("A1").Select
Dim last_cell As Variant
Dim last_column As Variant
Dim last_row As Variant
last_column = Range("B12").Value
last_row = Range("E12").Value
last_cell = Range("B15").Value
Dim rng As Range, cell As Range
Set rng = Range(Cells(1, 1), Cells(last_row, last_column))
For Each cell In rng
If cell.Locked = True Then
Else
cell.Value = "N/P"
End If
Next cell
With Application
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
the last column should be "13" and the last row should be "51"
but every time I get error 1004.
the problem is in the set rng
Define your row/column variables as Long and specify a workbook and worksheet for every object that is located in a worksheet.
Option Explicit
Public Sub Checker()
With Application
.DisplayAlerts = False
.EnableEvents = False
End With
Dim folderpath As String
folderpath = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
Dim workbookname As String
workbookname = ThisWorkbook.Worksheets("Sheet1").Range("B6").Value
Dim filepath As String
filepath = folderpath & workbookname 'concatenate strings with & not +
Dim OpenedWb As Workbook ' set the opened workbook as a variable so you can reference it later
Set OpenedWb = Workbooks.Open(Filename:=filepath)
Dim ws As Worksheet ' define the worksheet you want to use in that workbook
Set ws = OpenedWb.Worksheets(1) 'select your sheet by tab position or
'Set ws = OpenedWb.Worksheets("Sheet1") 'select your sheet by tab name
Dim last_column As Long
last_column = ws.Range("B12").Value
Dim last_row As Long
last_row = ws.Range("E12").Value
Dim rng As Range,
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(last_row, last_column))
Dim cell As Range
For Each cell In rng
If Not cell.Locked = True Then
cell.Value = "N/P"
End If
Next cell
'OpenedWb.Close SaveChanges:=True 'if you want to close and save
With Application
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
Note that if you disalbe events, then make sure you use error handling to enable events in any case of error or they will be turned of until you close Excel.
For Example
Public Sub Example()
Application.EnableEvents = False
On Error Goto SAVE_EXIT
' your code here …
Application.EnableEvents = True
On Error Goto 0 ' re-enable error reporting
Exit Sub
SAVE_EXIT: ' in case of error enable events
Application.EnableEvents = True
' and show error message
If Err.Number Then
Err.Raise Err.Number
End If
End Sub
I try to get a number copied from one list in one sheet to a new created sheet in specific cell. The code first check if there already exist a sheet with this name, if not it creates a new sheet and then add it and paste in a table from another sheet. After this is done I also want a number to be filled in from the list but I dont get it to work with FOR EACH as i did with first one. I really don't know how i shall do it? Im trying to get the inum to be written in each new sheet.
`Sub Sample()
Dim ws As Worksheet
Dim Row As Long
Dim inu As Long
Dim i As Long
'~~> Set this to the relevant worksheet
Set ws = Sheets("Röd")
Set wsi = Sheets("Röd")
With ws
'~~> Find last row in Column A
Row = .Range("A" & .Rows.Count).End(xlUp).Row
With wsi
inu = .Range("B" & .Rows.Count).End(xlUp).Row
'~~> Loop through the range
For i = 3 To Row
'~~> Check if cell is not empty
If Len(Trim(.Range("A" & i).Value2)) <> 0 Then
'~~> Whatever this fuction does. I am guessing it
'~~> checks if the sheet already doesn't exist
If SheetCheck(.Range("A" & i)) = False Then
With ThisWorkbook
'~~> Add the sheet
.Sheets.Add After:=.Sheets(.Sheets.Count)
'~~> Color the tab
.Sheets(.Sheets.Count).Tab.Color = RGB(255, 0, 0)
'~~> Name the tab
.Sheets(.Sheets.Count).Name = Left(ws.Range("A" & i).Value2, 30)
Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
.Sheets(.Sheets.Count).Range("B4").Value = ws.Range("A" & i).Value
Columns("A:B").AutoFit
Rows("1:25").AutoFit
For j = 3 To inu
'If Len(Trim(Range("B" & inu).Value2)) <> 0 Then
Sheets(Sheets.Count).Range("B3").Value2 = wsi.Range("B" & j).Value2
'End If
Next j
End With
End If
End If
Next i
End With
End With
End Sub`
Create Worksheets from List
Option Explicit
Sub createWorksheets()
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
Dim MyRange As Range
With wb.Worksheets("Röd").Range("A3")
Set MyRange = .Resize(.Worksheet.Cells(.Worksheet.Rows.Count, .Column) _
.End(xlUp).Row - .Row + 1)
End With
Application.ScreenUpdating = False
Dim MyCell As Range
For Each MyCell In MyRange.Cells
If Len(MyCell) > 0 Then
If Not SheetCheck(wb, MyCell.Value) Then
With wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
' Data
wb.Worksheets("Utredningsmall").Range("A1:B22").Copy _
Destination:=.Range("A1")
.Range("B3").Value = MyCell.Offset(, 1).Value
.Range("B4").Value = MyCell.Value
.Name = Left(MyCell.Value, 30)
' Formats
.Tab.Color = RGB(255, 0, 0)
.Columns("A:B").AutoFit
.Rows("1:25").AutoFit
End With
End If
End If
Next MyCell
Application.ScreenUpdating = True
End Sub
Function SheetCheck( _
wb As Workbook, _
ByVal SheetName As String) _
As Boolean
On Error Resume Next
Dim sh As Object: Set sh = wb.Sheets(SheetName)
On Error GoTo 0
SheetCheck = Not sh Is Nothing
End Function
Sub Röd()
Dim MyCell As Range, MyRange As Range
Dim ws As Worksheets
Dim inum As Range, Myinum As Range
'This Macro will create separate tabs based on a list in Distribution Tab A3, B3 down
Set MyRange = Sheets("Röd").Range("A3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.DisplayAlerts = False
For Each MyCell In MyRange
If SheetCheck(MyCell) = False And MyCell <> "" Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Tab.Color = RGB(255, 0, 0)
Sheets(Sheets.Count).Name = Left(MyCell.Value2, 30) ' renames the new worksheet
Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
Sheets(Sheets.Count).Range("B4").Value = MyCell.Value2
Sheets(Sheets.Count).Range("B3").Value = MyCell.Offset(, 1).Value
Columns("A:B").AutoFit
Rows("1:25").AutoFit
End If
Next
Application.DisplayAlerts = True
End Sub
OR
Sub Röd()
Dim MyCell As Range, MyRange As Range
Dim ws As Worksheets
Dim inum As Range, Myinum As Range
'This Macro will create separate tabs based on a list in Distribution Tab A3, B3 down
Set MyRange = Sheets("Röd").Range("A3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.DisplayAlerts = False
For Each MyCell In MyRange
If SheetCheck(MyCell) = False And MyCell <> "" Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Tab.Color = RGB(255, 0, 0)
Sheets(Sheets.Count).Name = Left(MyCell.Value2, 30) ' renames the new worksheet
Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
Sheets(Sheets.Count).Range("B4").Value = MyCell.Value2
Sheets(Sheets.Count).Range("B3").Value = MyCell.Offset(, 1).Value
Columns("A:B").AutoFit
Rows("1:25").AutoFit
End If
Next
Application.DisplayAlerts = True
End Sub
Function:
Function SheetCheck(MyCell As Range) As Boolean
Dim ws As Worksheet
SheetCheck = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = Left(MyCell.Value, 30) Then
SheetCheck = True
End If
Next
End Function
Both these codes works now. They go through a list and create a new sheet for each cell in the list.
I have a workbook that stores quite a bit of data. I am trying to import a weekly report, paste it in a table, loop through the imported information and if a row does not match the issue key in a second table, the row needs to be copied and pasted into the second table.
Everything works until it gets to the Paste part of the code. It seems that the selection does not stay copied? I have tried several troubleshooting methods but none have worked.
Sub Get_Data_From_File()
Dim FileToOpen As Variant
Dim DAHelpPulse As Workbook
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse & Import Jira Pulse Check", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen <> False Then
Set DAHelpPulse = Application.Workbooks.Open(FileToOpen)
DAHelpPulse.Sheets(1).Range("A2", Range("M2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Import").Visible = True
ThisWorkbook.Worksheets("Import").Range("A2").PasteSpecial xlPasteValues
DAHelpPulse.Close False
SearchandExtract
End If
Application.ScreenUpdating = False
End Sub
Sub SearchandExtract()
Dim datasheet As Worksheet
Dim ticketsheet As Worksheet
Dim homesheet As Worksheet
Dim issuekey As String
Dim finalrow As Integer
Dim i As Integer
Dim LastRow As Range
Dim TicketReviewTable As ListObject
Set datasheet = Sheet9
Set ticketsheet = Sheet2
Set homesheet = Sheet6
issuekey = ticketsheet.Range("B2").Value
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To finalrow
If Cells(i, 2) <> issuekey Then
Range(Cells(i, 1), Cells(1, 13)).Select
Selection.Copy
Sheet2.ListObjects("TicketReview").ListRows.Add
Set TicketReviewTable = Sheet2.ListObjects("TicketReview")
Set LastRow = TicketReviewTable.ListRows(TicketReviewTable.ListRows.Count).Range
With LastRow
LastRow.PasteSpecial xlPasteValues
End With
datasheet.Select
End If
Next i
homesheet.Select
End Sub
I don't think you really need to split this up into two subs - that just means you end up re-defining items already assigned in the first step.
Untested:
Sub Get_Data_From_File()
Dim FileToOpen As Variant, rngCopy As Range, rngPaste As Range
Dim DAHelpPulse As Workbook, tbl As ListObject, issuekey, rw As Range
FileToOpen = Application.GetOpenFilename(Title:="Browse & Import Jira Pulse Check", _
FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen <> False Then
Application.ScreenUpdating = False
Set DAHelpPulse = Application.Workbooks.Open(FileToOpen)
With DAHelpPulse.Sheets(1)
Set rngCopy = .Range(.Range("A2"), .Range("M2").End(xlDown))
End With
With ThisWorkbook.Worksheets("Import")
.Visible = True
Set rngPaste = .Range("A2").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
End With
rngPaste.Value = rngCopy.Value
DAHelpPulse.Close False 'no save
Set tbl = Sheet2.ListObjects("TicketReview")
issuekey = Sheet2.Range("B2").Value
For Each rw In rngPaste.Rows
If rw.Cells(2) <> issuekey Then
tbl.ListRows.Add.Range.Value = rw.Value
End If
Next rw
End If
End Sub
I have some code here but I'd like it to skip worksheets names Aggregated, Collated Results, Template, End. I have tried to add an If statement in to skip these but it doesn't seem to like it.
Sub FillBlanks()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
For Each ws In Worksheets
Set rng2 = ws.Range("L1:AB40")
On Error Resume Next
Set rng1 = rng2.SpecialCells(xlBlanks)
on error goto 0
if not rng1 is nothing then
Application.Iteration = True
rng1.FormulaR1C1 = "=AVERAGE(R[-1]C,R[1]C)"
Application.Iteration = False
rng2.Value = rng2.Value
end if
Next ws
End Sub
If you add the names of the sheets you want to skip to the line worksheetsToSkip = array("... (below), then the code below should skip said sheets.
Option Explicit
Sub FillBlanks()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim worksheetsToSkip As Variant
worksheetsToSkip = Array("Aggregated", "Collated Results", "Template", "End")
For Each ws In Worksheets
If IsError(Application.Match(ws.Name, worksheetsToSkip, 0)) Then
Set rng2 = ws.Range("L1:AB40")
On Error Resume Next
Set rng1 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng1 Is Nothing Then
Application.Iteration = True
rng1.FormulaR1C1 = "=AVERAGE(R[-1]C,R[1]C)"
Application.Iteration = False
rng2.Value = rng2.Value
End If
End If
Next ws
End Sub