Actually i have to find a column named "account" and i have to delete the data entered in that column.
Lets say Column name "Account" is in the cell "B9" and values have been entered till "B30"(it is variable), then i have to delete the data from "B10"to "B30". And also if i have one more column in the name of "account", then i have to do the same for that column also.
I have coded for one column. I want to write it for multiple columns.
Here is my coding,
Private Sub CommandButton1_Click()
Dim xlapp As Excel.Application
Dim wb As Workbook
Dim FindRow As Range
Dim ad As String
Dim AcCell As String
Dim de As String
Dim lad As String
Dim col As Integer
Dim rw As Integer
Dim r As Integer
Dim rw2 As Integer
Dim myrange As Range
On Error GoTo ErrHandler:
MsgBox "Please browse for the document"
Set xlapp = CreateObject("Excel.Application")
filestr1 = Application.GetOpenFilename()
Workbooks.Open Filename:=filestr1 , Notify:=False
With xlapp
Set rng1 = ActiveSheet.UsedRange.Find("Account", , xlValues, xlWhole)
col = rng1.Column
'MsgBox col'
rw = rng1.Row
'MsgBox rw'
r = rw + 1
'MsgBox r'
ad = rng1.Address
'MsgBox ad'
ActiveSheet.Range(ad).Activate
ActiveCell.Offset(1, 0).Activate
rw2 = ActiveCell.Row
de = ActiveCell.Address
'MsgBox de'
ActiveSheet.Cells(Rows.Count, col).End(xlUp).Activate
lad = ActiveCell.Address
'MsgBox lad'
Set myrange = ActiveSheet.Range(de & ":" & lad)
myrange.Select
Selection.ClearContents
On Error GoTo ErrHandler:
filestr4 = Application.GetSaveAsFilename("RemovedAccNo")
ActiveWorkbook.SaveAs (filestr4)
On Error GoTo ErrHandler:
End With
Exit Sub
ErrHandler:
MsgBox ("User Cancelled.")
End Sub
You can do this with the FindNext Method
This method "continues a search that was begun with the Find method"
Also, try to not use Select and Activate. With lot of datas, it's very bad for the performance.
Finally, you may check the rng1 content after your Find to avoid Range Error with this line :
If Not rng1 Is Nothing Then
Related
I'm trying to use vba to write an "X" into the column with the current date.
If I run the code from the debug window, where I write the code it works as intented, but as soon as I try to run it by clicking on the rectangle I assigned it to, it says "Not found".
Thanks in advance for any help or ideas.
The code:
Sub Button()
Dim wb As Workbook
Dim ws As Worksheet
Dim col As Long
Dim rng As Range
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet 2")
With ws.Cells
Set rng = .Find(what:=Format(Date))
If rng Is Nothing Then
MsgBox "Not found"
col = 1
Else
MsgBox "Found"
col = rng.Column
End If
End With
ws.Cells(10, col).Value = "X"
MsgBox "Wrote to Field: " & row & "," & col
End Sub
Try to replace Format(Date) with CDate(Date)
I am new to StackOverflow, but have been working on this problem for some time, and am pretty stuck. Right now, my code takes 'Name' input from a textbox, and if the data in column A matches the name that was input, it copies data from the entire row in that sheet, copies it to another sheet, then deletes the data from the original sheet, and tells the user how many rows were moved. This code is listed below:
I have two problems. One, I need an error check where if the name that is typed into the textbox does not exist, it displays a messagebox with that message, and two, I need to allow for this code to do what it does, but from seperate workbooks. As in, copy the data from a sheet in one workbook, and move it to a sheet in another workbook. My code only works within the same workbook right now.
Any and all help is appreciated. Thank you in advance.
Private Sub buttonDelete_Click()
'When the Delete button is clicked, the following function is ran to copy the row from Current Services, move it to Cancelled Services
'and then delete the row from Current Services.
Dim wkBk1 As Workbook
Dim wkBk2 As Workbook
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
Dim count As Long
On Error Resume Next
Set wkBk1 = Workbooks.Open("C:\Users\Nathan\Desktop\Sandbox\testMacro.xlsm")
Set wkBk2 = Workbooks.Open("C:\Users\Nathan\Desktop\Sandbox\testMacro2.xlsm")
If Err.Number = 1004 Then
MsgBox "File Does Not Exist"
End If
I = wkBk1.Worksheets("Current Customers").UsedRange.Rows.count
J = Worksheets("Cancelled Services").UsedRange.Rows.count
count = 0
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Cancelled Services").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Current Customers").Range("A1:A" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.count
If CStr(xRg(K).Value) = Me.fName.Value Then
count = count + 1
xRg(K).EntireRow.Copy Destination:=Worksheets("Cancelled Services").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Me.fName.Value Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
MsgBox count & " rows moved"
End Sub
EDIT : OK, here is one more wrinkle. What if I wanted to search through four or five different workbooks, and move all of the rows where the conditions are met into one worksheet called 'Cancelled Services' that will be a worksheet in one of the aforementioned workbooks.
There are a LOT of strange things going on in your code, so I've tried to clean it up a bit and left some comments as to why you shouldn't have some things in there. I've addressed the first part of your question, but in order to move rows between workbooks you need to decide what data you're looking to move and where, especially by fully qualifying your ranges using Workbook, or in your case, wkBk1 and wkBk2
Private Sub buttonDelete_Click()
'When the Delete button is clicked, the following function is ran to copy the row from Current Services, move it to Cancelled Services
'and then delete the row from Current Services.
Dim wkBk1 As Workbook, wkBk2 As Workbook
Dim xRg As Range, xCell As Range
Dim I As Long, J As Long, K As Long, count As Long
Dim MyName As String
'Assign our name value here
MyName = Me.fName.Value
'Let's use an error handler instead - this way our Err.Number will actually be triggered
On Error GoTo Handler
Set wkBk1 = Workbooks.Open("C:\Users\Nathan\Desktop\Sandbox\testMacro.xlsm")
Set wkBk2 = Workbooks.Open("C:\Users\Nathan\Desktop\Sandbox\testMacro2.xlsm")
On Error GoTo 0
I = wkBk1.Worksheets("Current Customers").UsedRange.Rows.count
J = Worksheets("Cancelled Services").UsedRange.Rows.count 'Need to add either wkBk1 or wkBk2 to the front of this
'We don't really NEED this, as count is initialized as 0 anyways
'count = 0
If J = 1 Then
'What is the purpose of this? Can it ever even return true if J = 1?
If Application.WorksheetFunction.CountA(Worksheets("Cancelled Services").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Current Customers").Range("A1:A" & I) 'Need to add either wkBk1 or wkBk2 to the front of this
'Here we check the range for the name. If it's not there, we throw a messsage box and exit the sub
If Not WorksheetFunction.CountIf(xRg, MyName) > 0 Then
MsgBox "Name doesn't exist in the range"
Exit Sub
End If
'Got rid of On Error Resume Next, we don't need it and it's sloppy coding
Application.ScreenUpdating = False
'This whole snippet needs to be changed
'Also since you're deleting rows, you need to step BACKWARDS through this loop
For K = 1 To xRg.count
If CStr(xRg(K).Value) = MyName Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Cancelled Services").Range("A" & J + 1)
xRg(K).EntireRow.Delete
'Why do we have this? We already know this is true?
'If CStr(xRg(K).Value) = MyName Then
K = K - 1
'End If
'Move count to AFTER we've actually moved the row, with On Error Resume Next your count could've gone up without a row being moved...
count = count + 1
J = J + 1
End If
Next
Application.ScreenUpdating = True
MsgBox count & " rows moved"
Handler:
If Err.Number = 1004 Then
MsgBox "File Does Not Exist"
End If
End Sub
This code uses FIND rather than looking at each row. It creates a range of all found rows as it goes and then copies the whole lot over in one hit before deleting the original values. Before ending it tells you how many it found.
This assumes that you have a textbox called fname and button called buttonDelete on a Userform.
Private Sub buttonDelete_Click()
Dim wrkBk1 As Workbook
Dim wrkBk2 As Workbook
Dim sPath As String
Dim wrkSht1 As Worksheet
Dim wrkSht2 As Worksheet
Dim rLastCell_Cur As Range
Dim rLastCell_Can As Range
Dim sNameToSearch As String
Dim rSearchRange As Range
Dim rFound As Range
Dim sFirstAddress As String
Dim lFoundCount As Long
Dim rFoundUnion As Range
sPath = "C:\Users\Nathan\Desktop\Sandbox\"
If Not (FileExists(sPath & "testMacro.xlsm") And FileExists(sPath & "testMacro2.xlsm")) Then
'One of the files doesn't exist so display message and exit.
MsgBox "One of the files does not exist.", vbOKOnly + vbCritical
Else
Set wrkBk1 = Workbooks.Open(sPath & "testMacro.xlsm")
Set wrkBk2 = Workbooks.Open(sPath & "testMacro2.xlsm")
If Not (WorkSheetExists("Current Customers", wrkBk1) And _
WorkSheetExists("Cancelled Services", wrkBk2)) Then
'One of the sheets doesn't exist so display message and exit.
MsgBox "One of the required sheets doesn't exist.", vbOKOnly + vbCritical
Else
'Find the limits of the two sheets.
Set wrkSht1 = wrkBk1.Worksheets("Current Customers")
Set rLastCell_Cur = LastCell(wrkSht1)
Set wrkSht2 = wrkBk2.Worksheets("Cancelled Services")
Set rLastCell_Can = LastCell(wrkSht2).Offset(1) 'We want the cell below the last cell here.
'Grab what we're searching for and where we're searching for it.
sNameToSearch = Me.fName
With wrkSht1
Set rSearchRange = .Range(.Cells(1, 1), .Cells(rLastCell_Cur.Row, 1))
End With
With rSearchRange
'Perform first search.
Set rFound = .Find(What:=sNameToSearch, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
'If something was found then we're good to go.
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
lFoundCount = lFoundCount + 1
'Create a union of ranges to copy over.
If rFoundUnion Is Nothing Then
Set rFoundUnion = rFound.EntireRow
Else
Set rFoundUnion = Union(rFoundUnion, rFound.EntireRow)
End If
'Look for the next item.
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
'All instances have been found so copy it all over and then delete the original.
rFoundUnion.Copy wrkSht2.Cells(rLastCell_Can.Row, 1)
rFoundUnion.Delete Shift:=xlUp
End If
MsgBox "Found " & lFoundCount & " occurrences of " & sNameToSearch, vbOKOnly + vbInformation
End With
End If
End If
End Sub
Public Function FileExists(FilePath As String) As Boolean
FileExists = Dir(FilePath) <> ""
End Function
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
This update to the buttonDelete_Click() procedure will open all Excel files within a specific folder and copy the found name to another file that isn't in that folder.
Private Sub buttonDelete_Click()
Dim colFiles As Collection
Dim vFile As Variant
Dim sTemp As String
Dim wrkBk1 As Workbook
Dim wrkBk2 As Workbook
Dim sPath As String
Dim wrkSht1 As Worksheet
Dim wrkSht2 As Worksheet
Dim rLastCell_Cur As Range
Dim rLastCell_Can As Range
Dim sNameToSearch As String
Dim rSearchRange As Range
Dim rFound As Range
Dim sFirstAddress As String
Dim lFoundCount As Long
Dim rFoundUnion As Range
sPath = "C:\Users\Nathan\Desktop\Sandbox\"
'Put the full path of each Excel file in to a collection.
'These contain the "Current Customers" sheet.
Set colFiles = New Collection
sTemp = Dir$(sPath & "*.xls*")
Do While Len(sTemp) > 0
colFiles.Add sPath & sTemp
sTemp = Dir$
Loop
If Not (FileExists("C:\Users\Nathan\Desktop\Cancelled.xlsx")) Then
'Cancelled Services book doesn't exist.
MsgBox "Cancelled Services doesn't exist.", vbOKOnly + vbCritical
Else
'Open Cancelled Services before working through the collection of Current Customers.
Set wrkBk2 = Workbooks.Open("C:\Users\Nathan\Desktop\Cancelled.xlsx")
Set wrkSht2 = wrkBk2.Worksheets("Cancelled Services")
For Each vFile In colFiles
Set wrkBk1 = Workbooks.Open(vFile)
'The file will only be processed if it contains "Current Customers" sheet.
If WorkSheetExists("Current Customers", wrkBk1) Then
Set wrkSht1 = wrkBk1.Worksheets("Current Customers")
Set rLastCell_Can = LastCell(wrkSht2).Offset(1)
Set rLastCell_Cur = LastCell(wrkSht1)
'Grab what we're searching for and where we're searching for it.
sNameToSearch = Me.fName
With wrkSht1
Set rSearchRange = .Range(.Cells(1, 1), .Cells(rLastCell_Cur.Row, 1))
End With
With rSearchRange
'Perform first search.
Set rFound = .Find(What:=sNameToSearch, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
'If something was found then we're good to go.
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
lFoundCount = lFoundCount + 1
'Create a union of ranges to copy over.
If rFoundUnion Is Nothing Then
Set rFoundUnion = rFound.EntireRow
Else
Set rFoundUnion = Union(rFoundUnion, rFound.EntireRow)
End If
'Look for the next item.
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
'All instances have been found so copy it all over and then delete the original.
rFoundUnion.Copy wrkSht2.Cells(rLastCell_Can.Row, 1)
rFoundUnion.Delete Shift:=xlUp
End If
End With
End If
Set rFound = Nothing
Set rFoundUnion = Nothing
sFirstAddress = ""
wrkBk1.Close SaveChanges:=True
Next vFile
MsgBox "Found " & lFoundCount & " occurrences of " & sNameToSearch, vbOKOnly + vbInformation
End If
End Sub
To answer the first question about checking if a sheet exist in a workbook, you can use a Function like this:
Public Function U_W_DoesWorksheetExist(ByVal sheetname As String, aWorkbook As Workbook) As Boolean
On Error Resume Next
U_W_DoesWorksheetExist = (Not aWorkbook.Sheets(sheetname) Is Nothing)
On Error GoTo 0
End Function
Now, when you reference the destination, you are saying just Worksheets("Cancelled Services") and the Macro will assume the ActiveWorkook as the main workbook where to copy the Sheet. You need to reference the Workbook where the sheet you are pasting is located. See if the code below works for you and take a look at the comments I added on it:
Private Sub buttonDelete_Click()
'When the Delete button is clicked, the following function is ran to copy the row from Current Services, move it to Cancelled Services
'and then delete the row from Current Services.
Dim wkBk1 As Workbook
Dim wkBk2 As Workbook
Dim xRg As Range
Dim xCell As Range
Dim i As Long
Dim J As Long
Dim K As Long
Dim count As Long
Dim arrFromWorkbookPath(1 To 4) As String
Dim c As Long
' If you need more than 4 rearrange the Array to as many as you need.
arrFromWorkbookPath(1) = "C:\Users\Nathan\Desktop\Sandbox\FromWB1.xlsm"
arrFromWorkbookPath(4) = "C:\Users\Nathan\Desktop\Sandbox\FromWB2.xlsm"
arrFromWorkbookPath(3) = "C:\Users\Nathan\Desktop\Sandbox\FromWB3.xlsm"
arrFromWorkbookPath(4) = "C:\Users\Nathan\Desktop\Sandbox\FromWB4.xlsm"
' The Workbook were you will be pasting the sheets.
Set wkBk2 = Workbooks.Open("C:\Users\Nathan\Desktop\Sandbox\testMacro2.xlsm")
For c = LBound(arrFromWorkbookPath) To UBound(arrFromWorkbookPath)
On Error Resume Next
' Open the Workbook from where the sheet will be copied from.
Set wkBk1 = Workbooks.Open(arrFromWorkbookPath(c))
If Err.Number = 1004 Then
MsgBox "File Does Not Exist"
Exit Sub
End If
' USE PROCEDURE LIKE THIS TO CHECK "Current Customers" in wkBk1 and Cancelled Services in wkBk2.
If U_W_DoesWorksheetExist("Current Customers", wkBk1) And U_W_DoesWorksheetExist("Cancelled Services", wkBk1) Then
i = wkBk1.Worksheets("Current Customers").UsedRange.Rows.count
J = wkBk2.Worksheets("Cancelled Services").UsedRange.Rows.count
count = 0
If J = 1 Then
If Application.WorksheetFunction.CountA(wkBk2.Worksheets("Cancelled Services").UsedRange) = 0 Then J = 0
End If
Set xRg = wkBk1.Worksheets("Current Customers").Range("A1:A" & i)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.count
If CStr(xRg(K).Value) = Me.fName.Value Then
count = count + 1
' Here you need to specify the workbook, not just the sheet wkBk2.Worksheets("Cancelled Services").
xRg(K).EntireRow.Copy Destination:=wkBk2.Worksheets("Cancelled Services").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Me.fName.Value Then
K = K - 1
End If
J = J + 1
End If
Next
wkBk1.Close False
Else
' Display error if the sheet doesn't exist.
MsgBox "Sheets Current Customers or Cancelled Services don't exists."
End If
Next c
Application.ScreenUpdating = True
End Sub
We've created a order sheet for all our machines, the main sheet is 'Order Sheet'.
And we're sending this sheet to the purchasing department at the end of the day.
When we run the macro to email the file, we wanted the macro to also copy each row to the specific machine worksheet. Eg. rows marked as 'Slicer' to go to the 'Slicer' sheet, 'blender' to 'blender', etc.
This is what I've got so far:
Sub PrintToNetwork()
ActiveWorkbook.Save
Range("A2:N25").Font.Size = 11
Dim OutApp As Object
Dim OutMail As Object
Dim answer As Integer
answer = MsgBox("Are you sure you want to Print & Send the sheet?", vbYesNo + vbQuestion, "Empty Sheet")
If answer = vbYes Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Retail Order Sheet"
.Body = "Hi Andy, Please order."
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Range("A1:N25").Select
ActiveSheet.PageSetup.PrintArea = "$A$1:$N$25"
oldprinter = Application.ActivePrinter
For i = 0 To 15
curNePrint = Format(i, "00")
On Error Resume Next
Application.ActivePrinter = "\\10.17.0.9\CCFN_Retail_MFP_BW on Ne" & curNePrint & ":"
Next i
ActiveWindow.Selection.PrintOut Copies:=1
Application.ActivePrinter = oldprinter
On Error GoTo 0
Else
End If
End Sub
Assuming the rows' location on the destination worksheet is determined by examining the same column as the one containing the worksheet names, something like the following might do the trick.
The DispatchRows sub scans prngWorksheetNames, looking for worksheets that exist by name.
You must call DispatchRows by passing it the range containing the worksheet names. For example, if the source worksheet names are on worksheet Summary, range C2:C50, you'd call DispatchRows ThisWorkbook.Worksheets("Summary").Range("C2:C50").
Option Explicit
'Copies entire rows to worksheets whose names are found within prngWorksheetNames.
'ASSUMPTION: on the destination worksheet, a copied row is appended at the lowest empty spot in the same column as prngWorksheetNames.
Public Sub DispatchRows(ByVal prngWorksheetNames As Excel.Range)
Dim lRow As Long
Dim rngWorksheetName As Excel.Range
Dim sDestWorksheetTabName As String
Dim oDestWs As Excel.Worksheet
Dim bScreenUpdating As Boolean
Dim bEnableEvents As Boolean
On Error GoTo errHandler
bScreenUpdating = Application.ScreenUpdating
bEnableEvents = Application.EnableEvents
Application.ScreenUpdating = False
Application.EnableEvents = False
For lRow = 1 To prngWorksheetNames.Rows.Count
Set rngWorksheetName = prngWorksheetNames.Cells(lRow, 1)
sDestWorksheetTabName = CStr(rngWorksheetName.Value)
If TryGetWorksheetByTabName(ThisWorkbook, sDestWorksheetTabName, oDestWs) Then
'Make sure there are no active autofilters on the destination worksheet, as they would typically interfere with the copy operation.
If oDestWs.FilterMode Then
oDestWs.ShowAllData
End If
'Copy and paste.
rngWorksheetName.EntireRow.Copy
oDestWs.Cells(oDestWs.Rows.Count, prngWorksheetNames.Column).End(xlUp).Offset(1).EntireRow.PasteSpecial xlPasteAll
End If
Next
Cleanup:
On Error Resume Next
Set rngWorksheetName = Nothing
Set oDestWs = Nothing
Application.CutCopyMode = False
Application.EnableEvents = bEnableEvents
Application.ScreenUpdating = bScreenUpdating
Exit Sub
errHandler:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
Resume Cleanup
End Sub
'Returns True, and a reference to the target worksheet, if worksheet psName is found by name on pwbkHost.
Public Function TryGetWorksheetByTabName(ByVal pwbkHost As Excel.Workbook, ByVal psName As String, ByRef pshtResult As Excel.Worksheet) As Boolean
Set pshtResult = Nothing
On Error Resume Next
Set pshtResult = pwbkHost.Worksheets(psName)
TryGetWorksheetByTabName = Not pshtResult Is Nothing
End Function
Here is very simple script to achieve what you want. Insert in your code appropriately, or call it from your macro. I tested this many times to make sure it works.
Sub CopyLines()
Dim mySheet
Dim LastRow As Long
Dim LastShtRow As Long
Dim j
LastRow = Sheets("Order Sheet").Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To LastRow Step 1
mySheet = Range("B" & j).Value
LastShtRow = Sheets(mySheet).Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & j & ":" & "N" & j).Copy
Sheets(mySheet).Range("A" & LastShtRow + 1).PasteSpecial xlPasteValues
Next j
Application.CutCopyMode = False
End Sub
I am attempting to write a macro in a workbook whose purpose is to display the key information from each of a set of excel files. the first column contains the name of the file which will be used in the code.
the code I have written so far should loop through the list of 11 file names in the summary sheet and pull the info called from cell E21 in each of those files and place it in cell Hx in the summary sheet.
I have had no luck getting it to work so far, my first error im getting is "invalid Qualifier" on the line that says "MySheet". I know that there are alot of other mistakes here as I have never attempted to write a sub that pulls from other closed workbooks.
My code is as follows:
Option Explicit
Sub OEEsummmary()
Dim Gcell As Range
Dim Txt$, MyPath$, MyWB$, MySheet$
Dim myValue As Integer
Dim x As Long
Dim v As Variant, r As Range, rWhere As Range
MyPath = "L:\Manufacturing Engineering\Samuel Hatcher\"
x = 2
MySheet = ActiveSheet.Name
Application.ScreenUpdating = False
Do While MySheet.Range("A" & x).Value <> ""
MyWB = MySheet.Range("A" & x).Txt
Workbooks.Open Filename:=MyPath & MyWB
Set Gcell = ActiveSheet.Range("E21")
With ThisWorkbook.ActiveSheet.Range("A" & x)
.Value = "Item"
.Offset(7, 0).Value = Gcell.Value
End With
ActiveWorkbook.Close savechanges:=False
x = x + 1
Loop
End Sub
Ive looked at what an invalid qualifier error is and i dont understand what i have wrong with that part of my code. Any help with this and any other blinding errors would be greatly appreciated!
The issue I see that's causing the Invalid Qualifier error is that you are declaring MySheet as a string, but trying to use it as a Worksheet object. Below I've declared it as a worksheet and set it to the Activesheet. I also changed the ThisWorkbook.ActiveSheet reference to MySheet, which I think is what you want. Also changed Txt to Text:
Sub OEEsummmary()
Dim Gcell As Range
Dim MySheet As Worksheet
Dim Txt$, MyPath$, MyWB$
Dim myValue As Integer
Dim x As Long
Dim v As Variant, r As Range, rWhere As Range
MyPath = "L:\Manufacturing Engineering\Samuel Hatcher\"
x = 2
Set MySheet = ActiveSheet
Application.ScreenUpdating = False
Do While MySheet.Range("A" & x).Value <> ""
MyWB = MySheet.Range("A" & x).Text
Workbooks.Open Filename:=MyPath & MyWB
Set Gcell = ActiveSheet.Range("E21")
With MySheet.Range("A" & x)
.Value = "Item"
.Offset(7, 0).Value = Gcell.Value
End With
ActiveWorkbook.Close savechanges:=False
x = x + 1
Loop
End Sub
Info
Workbook A: Has a master worksheet with a list of items, but the values are arranged in month columns
Workbook B: I have two sheets with different list of items I want to use to search Workbook A and return the current or specific month I need.
Note: Workbook B columns is offset, so we may need to account for this.
The code I have so far:
Sub Button()
Dim OpenFileName As String
Dim MyWB As Workbook, wb As Workbook
Dim aRange As Range
'Excel titled, "MODs", contains this module
Set MyWB = ThisWorkbook
'Ignore possible messages on a excel that has links
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
'Select and Open workbook
OpenFileName = Application.GetOpenFilename '("clients saved spreadsheet,*.xlsb")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName)
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
If MsgBox("Please select list range to search.", vbExclamation, "Search List") = vbOK Then
On Error Resume Next
Set aRange = Application.InputBox(prompt:="Enter range", Type:=8)
If aRange Is Nothing Then
MsgBox "Operation Cancelled"
Else
aRange.Select
End If
End If
End Sub
I might might be making this harder than I should be, so I am open to suggestions. I can't seem to find the right find function to use my selected range list and target the newly open workbook with the specific master worksheet (something similar to a vlookup).
Version 2: with a set range but I'm still getting not value returns
Sub Button()
Dim OpenFileName As String
Dim MyWB As Workbook, wb As Workbook
Dim MyWs As Worksheet, ws As Worksheet
Dim aRange As Range
'This line of code turns off the screen updates which make the macro run much faster.
'Application.ScreenUpdating = False
'Excel titled, "MODs", contains this module
Set MyWB = ThisWorkbook
Set MyWs = MyWB.Sheets("Sheet")
'Ignore possible messages on a excel that has links
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
'Select and Open workbook
OpenFileName = Application.GetOpenFilename '("clients saved spreadsheet,*.xlsb")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName)
On Error Resume Next
Set ws = Application.InputBox("Select a cell on the key sheet.", Type:=8).Parent
On Error GoTo 0
If ws Is Nothing Then
MsgBox "cancelled"
Else
MsgBox "You selected sheet " & ws.Name
End If
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
With MyWs
For Each aCell In .Range("A1:A10" & LastRow)
If Len(Trim(.Range("A19" & aCell.Row).Value)) <> 0 Then
.Cells(aCell.Row, 15) = Application.WorksheetFunction.VLookup( _
aCell.Value, ws.Range("A1:C18"), 2, 0)
End If
Next aCell
End With
'wb.Close (False)
'If MsgBox("Please select list range to search.", vbExclamation, "Search List") = vbOK Then
'On Error Resume Next
'Set aRange = Application.InputBox(prompt:="Enter range", Type:=8)
'If aRange Is Nothing Then
'MsgBox "Operation Cancelled"
'Else
'aRange.Select
'End If
'End If
'Return to default setting of screen updating.
'Application.ScreenUpdating = True
End Sub
I think the problem I'm running into is this code:
With MyWs
For Each aCell In .Range("A1:A10" & LastRow)
If Len(Trim(.Range("A19" & aCell.Row).Value)) <> 0 Then
.Cells(aCell.Row, 15) = Application.WorksheetFunction.VLookup( _
aCell.Value, ws.Range("A1:C18"), 2, 0)
begin declaringaCell as Range and lastRow as long
You seem to miss the definition of lastRow, which could be something like
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
then look carefully at .Range("A1:A10" & LastRow). Assume lastRow were 100 then this would set a range from A1 to A10100: is that what you want? Or may be you'd use
.Range("A1:A" & lastRow)
again .Range("A19" & aCell.Row) would lead to a single cell address such as "A1989" (were aCell.Row = 89): is that what you want?
other than what above I can't grasp the actual scenario of what you're searching where. You may want to provide more info about that