I have a workbook containing a list of all invoices from all branches, let's call it "Everything", and basically I need to search if the invoices are found in another file containing each branch's invoices,. It's actually on file for each branch, and each file is divided with sheets by month, and I need to check in every sheet and then insert a value in a cell. Let's call this one "0001" and so on for each branch.
The "everything" file contains basically one column with the branch number, one with the invoice number, one with the issuer code and one saying if it was found on the branches files. The branches files contains the same except the branch number, and the last column says if the invoice is on the "Everything" file or not. There are cases where an invoice is on the branch file and is not on the "everything file" and also cases where it is on the everything file and is not on the branches file.
What I tried to do was insert a loop in VBA so it would go automatically invoice after invoice in the everything file and open the specific branch file, then search for the invoice number in each sheet. I would also need to check if the issuer is the same, but first I tried this code and when it searched for the value it returned the wrong cell! Here is the code:
Dim sh As Worksheet
Dim iLoop As Integer
For iLoop = 7 To 1719
' this is where the invoices are in an excel sheet
iloopoffset = iLoop - 6
' as you see above, the list of invoices starts at line 7, so I used this to offset
If Range("K6").Offset(iloopoffset).Value = "No" Then
' Column K is the one saying if the invoice was found or not in the branches file
Set searchedvalue = Range("B6").Offset(iloopoffset, 0)
' I used this so i could use the value in the .find formula
MsgBox (searchedvalue.Value)
Workbooks.Open ("C:\Users\xxxxxx\Documents\xxxxxx\XML " + Range("D6").Offset(iloopoffset).Value)
For Each sh In Worksheets
If ActiveSheet.Name = "062015" Or "052015" Or "042015" Or "032015" Or "022015" Or "012015" Or "122014" Or "112014" Then
' I needed to do this because on the sheets with the names above, the searched value will be in another column. sheets before 112014 are different.
Set NFE = Worksheets(sh.Name).Range("B:B").Find(Range("B6").Offset(iloopoffset, 0).Value, lookat:=xlPart)
Else
Set NFE = Worksheets(sh.Name).Range("A:A").Find(Range("B6").Offset(iloopoffset, 0).Value, lookat:=xlPart)
End If
If Not NFE Is Nothing Then
MsgBox ("Found on sheet " + ActiveSheet.Name + " " + NFE.Address)
Range(NFE.Address).Offset(, 12).Value = "YES"
' yes for found
ActiveWorkbook.Save
ActiveWindow.Close
End If
Next sh
ActiveWorkbook.Save
ActiveWindow.Close
End If
Next iLoop
End Sub
What is going on? I am a true noob in VBA, but i didn't find anything wrong with this code... can you help me?
Untested:
Sub test()
Const FILE_ROOT As String = "C:\Users\xxxxxx\Documents\xxxxxx\XML "
Dim shtAll As Worksheet, rw As Range, searchedvalue
Dim sh As Worksheet, wb As Workbook
Dim iLoop As Long, colSrch As Long, NFE As Range
Dim arrSheets
Set shtAll = ActiveWorkbook.Sheets("Everything") 'adjust to suit...
'sheets to watch out for....
arrSheets = Array("062015", "052015", "042015", "032015", "022015", _
"012015", "122014", "112014")
For iLoop = 7 To 1719
Set rw = shtAll.Rows(iLoop)
'if not found...
If rw.Cells(1, "K").Value = "No" Then
searchedvalue = rw.Cells(1, "B").Value
Set wb = Workbooks.Open(FILE_ROOT & rw.Cells(1, "D").Value)
For Each sh In wb.Worksheets
'which column to search in? check if sheet name is in arrSheets
colSrch = IIf(IsError(Application.Match(sh.Name, arrSheets, 0)), 1, 2)
Set NFE = sh.Columns(colSrch).Find(searchedvalue, lookat:=xlPart)
If Not NFE Is Nothing Then
MsgBox ("Found on sheet " + ActiveSheet.Name + " " + NFE.Address)
NFE.Offset(, 12).Value = "YES"
wb.Save
Exit For
End If
Next sh
wb.Close savechanges:=False
End If
Next iLoop
End Sub
EDIT
If Not NFE Is Nothing And sh.Range(NFE).Offset(, 8) = cnpj Then
A couple of problem I see here:
NFE is already a Range, so you can just do NFE.Offset(,8)
VBA will always evaluate both parts of an And, even if the first part is False, so in cases where NFE is Nothing the second part will cause a run-time error (since you can't Offset from Nothing...). To handle this you need two distinct If blocks:
If Not NFE Is Nothing Then
If NFE.Offset(, 8) = cnpj Then
'do something
End If
End If
Should do it.
Related
I am a novice coder. I have found a few examples and tutorials to get my code to where it is, but it returns an
error "400"
which I have found to not be all that easy to diagnose. My goal is simple. I have a 2 sheet workbook. Sheet 1 is an order form ("PO"), and sheet 2 is a database ("DataBase"). I have this subroutine in the workbook (not one of the sheets). It prompts the user to scan a barcode, and then searches sheet "DataBase" for that part number, and then copy/pastes the next 3 cells to the right back into the original sheet "PO".
There is a little more built in, like the ability to terminate the loop if a specific barcode is scanned (xxxDONExxxx). I also am trying to find a way to to return an error message (ErrMsg2) if no match is found.
If I step through the subroutine using F8, it gets past the scanner input, and then fails the line with the note ('FAIL'). I would appreciate some help to get this working.
Option Explicit
Sub inventory()
'**** Define variables ****'
Dim partnumber As String
Dim lastrow As Integer
Dim i As Integer
Dim x As Integer
'Dim xxxDONExxxx As String
'**** Clear paste area in sheet "PO" ****'
Sheets("PO").Range("A17:F31").ClearContents
'**** Set row count ****'
lastrow = 100 'Sheets("DataBase").Range("B500").End(x1Up).Row
'**** select first cell to paste in****'
Range("A17").Select
'**** loop for scanning up to 30 lines ****'
For i = 1 To 30
'**** Prompt for input ****'
partnumber = InputBox("SCAN PART NUMBER")
'**** Abort if DONE code is scanned ****'
If ("partnumber") = ("xxxDONExxxx") Then GoTo ErrMsg1
'**** search DataBase for match in B, copy CDE /paste in PO BDE****'
For x = 2 To lastrow
If ("partnumber") = Sheets("DataBase").Range("x, 2") Then '*FAIL*'
ActiveCell.Offset(0, 1) = Sheets("DataBase").Cells(x, 1)
ActiveCell.Offset(0, 2) = Sheets("DataBase").Cells(x, 2)
ActiveCell.Offset(0, 3) = Sheets("DataBase").Cells(x, 3)
End If
Next x
Next i
ErrMsg1:
MsgBox ("Operation Done - user input")
ErrMsg2:
MsgBox ("Part Number does not Exist, add to DataBase!")
End Sub
Sheet 1 - "PO"
Sheet 2 - "Database"
I know there are more efficient ways to do this, but this will do what you expect:
Option Explicit
Sub inventory()
'**** Define variables ****'
Dim wsData As Worksheet: Set wsData = Sheets("DataBase")
Dim wsPO As Worksheet: Set wsPO = Sheets("PO")
Dim partnumber As String
Dim lastrow As Long
Dim i As Long
Dim x As Long
Dim Found As String
Found = False
'**** Clear paste area in sheet "PO" ****'
wsPO.Range("A17:F31").ClearContents
'**** Set row count on Database Sheet ****'
lastrow = wsData.Cells(wsData.Rows.Count, "B").End(xlUp).Row
'select the last row with data in the given range
wsPO.Range("A17").Select
ScanNext:
'**** Prompt for input ****'
partnumber = InputBox("SCAN PART NUMBER")
'**** Abort if DONE code is scanned ****'
If partnumber = "xxxDONExxxx" Then
MsgBox ("Operation Done - user input")
Exit Sub
Else
Selection.Value = partnumber
End If
'**** search DataBase for match in B, copy CDE /paste in PO BDE****'
For x = 2 To lastrow
If wsPO.Cells(Selection.Row, 1) = wsData.Cells(x, 2) Then
wsPO.Cells(Selection.Row, 2) = wsData.Cells(x, 3)
wsPO.Cells(Selection.Row, 5) = wsData.Cells(x, 4)
wsPO.Cells(Selection.Row, 6) = wsData.Cells(x, 5)
Found = "True"
End If
Next x
If Found = "False" Then
MsgBox "Product Not Found in Database!", vbInformation
Selection.Offset(-1, 0).Select
Else
Found = "False"
End If
If Selection.Row < 31 Then
Selection.Offset(1, 0).Select
GoTo ScanNext
Else
MsgBox "This inventory page is now full!", vbInformation
End If
End Sub
I'm a big fan of application.match. For example:
If IsNumeric(Application.Match(LookUpValue, LookUpRange, 0)) Then
startCol = Application.Match(LookUpValue, LookUpRange, 0)
Else
MsgBox "Unable to find " & LookUpValue & " within " & LookUpRange & ". Please check the data and try again. The macro will now exit"
End
End If
This tests if the item exists in the dataset, then does something with it if it exists. If it doesn't exist, you can throw an error message. Massaging it slightly for your needs:
If IsNumeric(Application.Match(PartNumber, DataBaseRange, 0)) Then
'Do things with matching
Else
'Do things when you don't have a match
End
End If
Try this rethink version. You should create a Sub to add new unknown items into the Database range, otherwise you need to quit current process, add new item into Database, then rescan all items from beginning!
Option Explicit
Sub inventory()
'**** Define variables ****'
Const STOP_ID As String = "xxxDONExxxx"
Const START_ROW As Long = 17 ' based on "A17:F31"
Const LAST_ROW As Long = 31 ' based on "A17:F31"
Dim partnumber As String, sDescription As String, i As Long
Dim oRngDataBase As Range
'**** Clear paste area in sheet "PO" ****'
Worksheets("PO").Range("A17:F31").ClearContents
' Determine the actual database range
Set oRngDataBase = Intersect(Worksheets("DataBase").UsedRange, Worksheets("DataBase").Columns("B:E"))
i = START_ROW
On Error Resume Next
Do
partnumber = InputBox("SCAN PART NUMBER")
If Len(partnumber) = 0 Then
If partnumber = STOP_ID Then
MsgBox "Operation Done - user input", vbInformation + vbOKOnly
Exit Do
End If
sDescription = WorksheetFunction.VLookup(partnumber, oRngDataBase, 2, False) ' Description
If Len(sDescription) = 0 Then
If vbYes = MsgBox("Part Number (" & partnumber & ") does not Exist, add to DataBase Now?", vbExclamation + vbYesNo) Then
' Suggest you to create a new Sub to insert data and call it here
' Update the Database Range once added new item
Set oRngDataBase = Intersect(Worksheets("DataBase").UsedRange, Worksheets("DataBase").Columns("B:E"))
End If
'NOTE: Answer No will skip this scanned unknown partnumber
Else
Worksheets("PO").Cells(i, "A").Value = partnumber
Worksheets("PO").Cells(i, "B").Value = sDescription
Worksheets("PO").Cells(i, "C").Value = WorksheetFunction.VLookup(partnumber, oRngDataBase, 3, False) ' QTY
Worksheets("PO").Cells(i, "D").Value = WorksheetFunction.VLookup(partnumber, oRngDataBase, 4, False) ' PRICE
i = i + 1
End If
End If
Loop Until i > LAST_ROW
On Error GoTo 0
Set oRngDataBase = Nothing
End Sub
I'm trying to build a new VBA function for Excel. I've got a book of sheets with a front page that always loads first, on this page I've got a combo box that lists all the other sheets in the book and a nice extract button that will pull out the chosen sheet to a new book. (Thanks to those here who helped with that). Now I need a new function that will use the same combo box, but instead only extract a small subset of the chosen sheet.
Unfortunately, that subset isn't on the same rows for every sheet, nor is the number of rows the same (so one sheet, the subset might be 10 rows, on another it might be 12, on another it might be 20, etc etc etc).
On the plus side, there are merged rows (from column A to G) at the start and end of each subset - with specific text, which could be used to search for.
After some back and forth, I've got a better bit of code that I think is almost working:
Sub ZCPS_Extract()
Dim StartRow
Dim EndRow
Dim Zws As Worksheet
Dim wbkOriginal As Workbook
Set wbkOriginal = ActiveWorkbook
StartRow = 1
EndRow = 1
'sets site details into the header of the ZCPS checksheet
Worksheets(Sheet1.CmbSheet.Value).Range("B3").Value = Worksheets("front page").Range("E6")
Worksheets(Sheet1.CmbSheet.Value).Range("D3").Value = Worksheets("front page").Range("N6")
Worksheets(Sheet1.CmbSheet.Value).Range("F3").Value = Worksheets("front page").Range("K6")
Set Zws = Sheets(Sheet1.CmbSheet.Value)
'selects ZCPS block from select estate sheet
StartRow = (Zws.Cells.Find("**** ZCPS Installation").Row) + 1
EndRow = (Zws.Cells.Find("**** Aztec Hotfixes").Row) - 1
'copy above block and paste into Z-MISC starting at row 5
Worksheets(Sheet1.CmbSheet.Value).Range(Cells(StartRow, 1), Cells(EndRow, 7)).Copy Worksheets("Z-MISC").Range("A5")
With ActiveWorkbook.Sheets("Z-MISC")
.Copy
ActiveWorkbook.SaveAs _
"C:\temp\" _
& ActiveWorkbook.Sheets("Z-MISC").Cells(3, 2).Text _
& " ZCPS CheckSheet " _
& Format(Now(), "DD-MM-YY") _
& ".xlsm", _
xlOpenXMLWorkbookMacroEnabled, , , , False
End With
'code to close the original workbook to prevent accidental changes etc
Application.DisplayAlerts = False
wbkOriginal.Close
Application.DisplayAlerts = True
End Sub
It's error on the line for copying, I'm getting a runtime error of "Application-defined or object-defined error" which to my limited knowledge isn't helping me. Any assistance/pointers/suggestions are welcomed.
Sub ismerged()
Dim start As Integer, finish As Integer
For i = 1 To Range("A655").End(3).Row + 1
If Cells(i, "A").MergeCells = True Then
start = i
Exit For
End If
Next
For i = start To Range("A655").End(3).Row + 1
If Cells(i, "A").MergeCells = True Then
finish = i
End If
Next
MsgBox start
MsgBox finish
End Sub
Then I guess you can select your data as you wish.
I'm not sure about the way you reference your sheet. I will assume 'comboboxvalue' contains the name or the number of the sheet you are selecting. Your code should be something like the following.
Sub Z_Extract()
Dim StartRow
Dim EndRow
Dim ws As Worksheet
Set ws = Sheets(comboboxvalue)
StartRow = ws.Cells.Find("**** ZC").Row
EndRow = ws.Cells.Find("****").Row
'Im assuming you have values up to column G
ws.Range(ws.Cells(StartRow, 1), Cells(EndRow, 7)).Copy
'Now that you have the correct Range selected you can copy it to your new workbook
'SelectedRange.Copy Etc.....
'Cleanup
Set ws = Nothing
End Sub
Got it working.
Set Zws = Sheets(Sheet1.CmbSheet.Value)
'selects ZCPS block from selected estate sheet
StartRow = (Zws.Cells.Find("**** ZCPS Installation").Row)
EndRow = (Zws.Cells.Find("**** Aztec Hotfixes").Row) - 1
'copy above block and paste into Z-MISC starting at row 10
Sheets(Sheet1.CmbSheet.Value).Activate
ActiveSheet.Range(Cells(StartRow, 1), Cells(EndRow, 7)).Select
Selection.Copy
Sheets("Z-MISC").Select
Range("A10").Select
ActiveSheet.Paste
Can anyone walk me through how to write a script to delete the entire row if a cell in column D = "" on sheet 3 in range D13:D40.
Also, how to prevent the user from accidentally running the script again once those cells in the range are already deleted and other cells are now on the D13:D40 range?
Solution: This is working for me:
Sub DeleteRowsWithEmptyColumnDCell()
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.ActiveSheet.Range("D13:D40")
With rng
' Loop through all cells of the range
' Loop backwards, hence the "Step -1"
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
' Since cell is empty, delete the whole row
.Item(i).EntireRow.Delete
End If
Next i
End With
End Sub
Explanation: Run a for loop through all cells in your Range in column D and delete the entire row if the cell value is empty. Important: When looping through rows and deleting some of them based on their content, you need to loop backwards, not forward. If you go forward and you delete a row, all subsequent rows get a different row number (-1). And if you have two empty cells next to each other, only the row of the first one will be deleted because the second one is moved one row up but the loop will continue at the next line.
No need for loops:
Sub SO()
Static alreadyRan As Integer
restart:
If Not CBool(alreadyRan) Then
With Sheets("Sheet3")
With .Range("D13:D40")
.AutoFilter 1, "="
With .SpecialCells(xlCellTypeVisible)
If .Areas.Count > 1 Then
.EntireRow.Delete
alreadyRan = alreadyRan + 1
End If
End With
End With
.AutoFilterMode = False
End With
Else
If MsgBox("procedure has already been run, do you wish to continue anyway?", vbYesNo) = vbYes Then
alreadyRan = 0
GoTo restart:
End If
End If
End Sub
Use AutoFilter to find blank cells, and then use SpecialCells to remove the results. Uses a Static variable to keep track of when the procedure has been run.
Here's my take on it. See the comments in the code for what happens along the way.
Sub deleterow()
' First declare the variables you are going to use in the sub
Dim i As Long, safety_net As Long
' Loop through the row-numbers you want to change.
For i = 13 To 40 Step 1
' While the value in the cell we are currently examining = "", we delete the row we are on
' To avoid an infinite loop, we add a "safety-net", to ensure that we never loop more than 100 times
While Worksheets("Sheet3").Range("D" & CStr(i)).Value = "" And safety_net < 100
' Delete the row of the current cell we are examining
Worksheets("Sheet3").Range("D" & CStr(i)).EntireRow.Delete
' Increase the loop-counter
safety_net = safety_net + 1
Wend
' Reset the loop-counter
safety_net = 0
' Move back to the top of the loop, incrementing i by the value specified in step. Default value is 1.
Next i
End Sub
To prevent a user from running the code by accident, I'd probably just add Option Private Module at the top of the module, and password-protect the VBA-project, but then again it's not that easy to run it by accident in the first place.
This code executes via a button on the sheet that, once run, removes the button from the worksheet so it cannot be run again.
Sub DeleteBlanks()
Dim rw As Integer, buttonID As String
buttonID = Application.Caller
For rw = 40 To 13 Step -1
If Range("D" & rw) = "" Then
Range("D" & rw).EntireRow.Delete
End If
Next rw
ActiveSheet.Buttons(buttonID).Delete
End Sub
You'll need to add a button to your spreadsheet and assign the macro to it.
There is no need for loops or filters to find the blank cells in the specified Range. The Range.SpecialCells property can be used to find any blank cells in the Range coupled with the Range.EntireRow property to delete these. To preserve the run state, the code adds a Comment to the first cell in the range. This will preserve the run state even if the Workbook is closed (assuming that it has been saved).
Sub DeleteEmpty()
Dim ws As Excel.Worksheet
Set ws = ActiveSheet ' change this as is appropriate
Dim sourceRange As Excel.Range
Set sourceRange = ws.Range("d13:d40")
Dim cmnt As Excel.Comment
Set cmnt = sourceRange.Cells(1, 1).Comment
If Not cmnt Is Nothing Then
If cmnt.Text = "Deleted" Then
If MsgBox("Do you wish to continue with delete?", vbYesNo, "Already deleted!") = vbNo Then
Exit Sub
End If
End If
End If
Dim deletedThese As Excel.Range
On Error Resume Next
' the next line will throw an error if no blanks cells found
' hence the 'Resume Next'
Set deletedThese = sourceRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not deletedThese Is Nothing Then
deletedThese.EntireRow.Delete
End If
' for preserving run state
If cmnt Is Nothing Then Set cmnt = sourceRange.Cells(1, 1).AddComment
cmnt.Text "Deleted"
cmnt.Visible = False
End Sub
I've recently had to write something similar to this. I'm not sure that the code below is terribly professional, as it involves storing a value in cell J1 (obviously this can be changed), but it will do the job you require. I hope this helps:
Sub ColD()
Dim irow As long
Dim strCol As String
Sheets("sheet2").Activate
If Cells(1, 10) = "" Then
lrun = " Yesterday."
Else: lrun = Cells(1, 10)
End If
MsgBox "This script was last run: " & lrun & " Are you sure you wish to continue?", vbYesNo
If vbYes Then
For irow = 40 To 13 step -1
strCol = Cells(irow, 4).Value
If strCol = "" Then
Cells(irow, 4).EntireRow.Delete
End If
Next
lrun = Now()
Cells(1, 10) = lrun
Else: Exit Sub
End If
End Sub
Chopped down from uber-detail history mode per suggestion.
My level of expertise: Hacked some fairly complex dialog-boxing multi-workbook macro systems ten years ago, experienced but not formally trained and rusty.
The complicated stuff in this macro works; its central bug is that it won't change that CurrentClientAnchor Range variable, the most basic operation in Excel VBA, no matter what I do. It loops as many times as you like anchored on cell A2, correctly finding the cell that should next become CurrentClientAnchor (on the real data, A4, two cells down), and creating the invoice sheet perfectly from the selected data as long as you give it permission to overwrite the copy it just created a second ago. I won't be surprised if my special last record routine breaks something, but manually stepping through, none of that If clause ever runs. The program correctly steps over it. WhatsMyAnchor should be 4 just before the last Loop command, but never changes from 2.
The only method I know for accomplishing what I want that doesn't have a commented fossil left in the code is the first one I wrote, assigning a ClientsRange as Range over Range("A2", Cells(LastRow,1)) and then putting everything in a For...Next loop. That version also just ran over and over on the first record.
In what way am I being incredibly stupid, please?
Option Explicit
Sub FillOutInvoices()
Dim BilledDate As String
Dim ServiceYear As String
Dim ServiceMonth As String
Dim CompBasePath As String
Dim InvoiceTemplatePath As String
InvoiceTemplatePath = "H:\Comp\Comp Invoice BLANK PRINT COPY.xls"
'The info to change for each invoicing
'========================
'========================
CompBasePath = "H:\Comp\2014 Invoices\"
ServiceYear = "2014"
ServiceMonth = "September"
BilledDate = "02/01/2015"
'========================
'========================
Dim InvoiceFolder As String
InvoiceFolder = CompBasePath & ServiceYear & " " & ServiceMonth & " generated invoices" & "\"
If Dir(InvoiceFolder, vbDirectory) = vbNullString Then
MkDir InvoiceFolder
End If
'Find the last used row on the sheet with a web recipe to speed things up
'and avoid arbitrary search windows.
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
'We assume our first client is in A2
Dim CurrentClientAnchor As Range
Set CurrentClientAnchor = Range("A2")
Dim DataHeight As Single
Dim NoMoreRecords As Boolean
NoMoreRecords = False
'Debugging variable so I don't have to paw through
'a zillion properties of CCA in the Watch pane all the time
Dim WhatsMyAnchor As Single
WhatsMyAnchor = CurrentClientAnchor.Row
Do Until NoMoreRecords = True 'Loop captures falling through the last record, internal exit catches
'the next result each time
'Surprisingly the main loop. For each client, find the next one or end of job,
'use that as an upper and lower bound to create and write the invoice
'Transplanted inline from what should be a sub, because I need it to Just Work Now.
'As a sub, causes Object Required error on passing the range which is a range into the range slot that's designated as a range.
'This should become some clever run-once array of nonempty ranges someday
'Find next nonempty A. If none before lastrow, last record; find last nonempty F, set rows, copy data, terminate macro.
'If found, set rows and copy data
DataHeight = 1
Do Until CurrentClientAnchor.Offset(DataHeight, 0).Value <> ""
'Find the next nonempty cell below CurrentClientAnchor and record the offset
'We're falling off the bottom of the last one, have to do our special last search up front here.
If CurrentClientAnchor.Offset(DataHeight, 0).Row = LastRow Then 'special finder for last record down F to first empty cell
NoMoreRecords = True
DataHeight = 1
Do Until CurrentClientAnchor.Offset(DataHeight, 5).Value = ""
DataHeight = DataHeight + 1
Loop
Exit Do
End If
DataHeight = DataHeight + 1
Loop
'We now have our DataHeight value for the grunt work.
'Subtract one from it, to convert to the cell offsets we'll use
DataHeight = DataHeight - 1
'Inlined from sub again because I apparently don't know how to pass a variable.
'MakeInvoiceFile
Dim SourceBook As Workbook
Set SourceBook = ThisWorkbook
Dim InvoiceFileName As String
InvoiceFileName = InvoiceFolder & _
CurrentClientAnchor.Value & " " & ServiceYear & " " & ServiceMonth & " Invoice" & ".xls"
Dim DestBook As Workbook
Dim Template As Workbook
Application.Workbooks.Open InvoiceTemplatePath
Set Template = ActiveWorkbook
Set DestBook = ActiveWorkbook
DestBook.SaveAs (InvoiceFileName)
SourceBook.Activate
'Close for debugging cleanliness, more elegant keep open behavior later
'Doesn't work. Maybe not even ugly, anyway cut for dev time.
'Template.Close
'More debugging watchable variables
Dim WhereCopyingRow As Single
Dim WhereCopyingColumn As Single
Dim CopyRange As Range
'Client name into job name
Set CopyRange = CurrentClientAnchor
WhereCopyingRow = CopyRange.Row
WhereCopyingColumn = CopyRange.Column
CopyRange.Copy
DestBook.Sheets(1).Cells(3, 4).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
'Service address into job location
Set CopyRange = CurrentClientAnchor.Offset(0, 3)
WhereCopyingRow = CopyRange.Row
WhereCopyingColumn = CopyRange.Column
CopyRange.Copy
DestBook.Sheets(1).Cells(4, 4).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
'Billing address into billing address
Set CopyRange = CurrentClientAnchor.Offset(0, 4)
WhereCopyingRow = CopyRange.Row
WhereCopyingColumn = CopyRange.Column
CopyRange.Copy
DestBook.Sheets(1).Cells(9, 2).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
'Billing Date into Date Billed
'Currently discarded for progress
'DestBook.Sheets(1).Cells(24, 3).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
'Descriptions
Set CopyRange = Range(CurrentClientAnchor.Offset(0, 5), CurrentClientAnchor.Offset(DataHeight, 5))
WhereCopyingRow = CopyRange.Row
WhereCopyingColumn = CopyRange.Column
CopyRange.Copy
DestBook.Sheets(1).Cells(13, 2).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
'Totals
Set CopyRange = Range(CurrentClientAnchor.Offset(0, 14), CurrentClientAnchor.Offset(DataHeight, 15))
WhereCopyingRow = CopyRange.Row
WhereCopyingColumn = CopyRange.Column
CopyRange.Copy
DestBook.Sheets(1).Cells(13, 6).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
'Overall total
Set CopyRange = CurrentClientAnchor.Offset(DataHeight, 16)
WhereCopyingRow = CopyRange.Row
WhereCopyingColumn = CopyRange.Column
CopyRange.Copy
DestBook.Sheets(1).Cells(24, 6).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
DestBook.Save
DestBook.Close
'SourceBook appears to be activated when we close DestBook, but it's failing to iterate so let's make sure.
SourceBook.Activate
'CurrentClientAnchor = CurrentClientAnchor.Offset(DataHeight + 1, 0)
'WhatsMyAnchor = CurrentClientAnchor.Row
'Apparently we can't assign a range to its offset, fails to iterate, so
'we pop out to selection and back to the variable.
'CurrentClientAnchor.Offset(DataHeight + 1, 0).Select
'CurrentClientAnchor = Selection
'WhatsMyAnchor = CurrentClientAnchor.Row
'Nope. Escalate to activating and assigning.
'CurrentClientAnchor.Offset(DataHeight + 1, 0).Activate
'CurrentClientAnchor = ActiveCell
'WhatsMyAnchor = CurrentClientAnchor.Row
'That doesn't iterate either, it's really hard for a programming language in
'Excel to iterate on the most common object in Excel,
'so let's turn the blasted stupid debugging variable into an absolute cell selector
Set CurrentClientAnchor = ActiveSheet.Cells(WhatsMyAnchor + DataHeight + 1, 0)
WhatsMyAnchor = CurrentClientAnchor.Row
'That throws a 1004 error with or without the Set, "application or object-defined error", thanks.
'It's just impossible to move a Range down a few cells. Excel VBA can't do that. You can't vary a Range variable.
Loop
MsgBox "All successfully written"
End Sub
That is a lot of writing for a relatively small question, I would recommend cutting out any non-essential text in future questions; a lot of people will just see the sheer volume of text and move on.
With respect to your issue I think a minor change would do the job:
The examples you have commented out should work if you just add Set in front of them:
Set CurrentClientAnchor = CurrentClientAnchor.Offset(DataHeight + 1, 0)
As you have it with the line
Set CurrentClientAnchor = ActiveSheet.Cells(WhatsMyAnchor + DataHeight + 1, 0)
Changed to
Set CurrentClientAnchor = ActiveSheet.Range("A" & WhatsMyAnchor + DataHeight + 1)
Should also work.
I'm attempting to create an inventory system at my work as the only software we have as Excel. Basically we have a Work order sheet that we enter the repairs as well as parts used on. I made a code that would pull the inserted part numbers & descriptions out of the individual work orders to keep track of everything used, but my boss wants me to create a system that will allow us to start typing the name/part number of something and have it guess or fill in for us. Hence where the combobox comes in.
I got It working up to a point. The lists are populated with the part inventory (we have a master EXTNERAL file listing) but my issue is this:
When you click the "add part" of the user form, I can't figure out how to have the parts be added in a certain range on the Work Order. All the tutorials I've been following here and here only have it set up to add the parts in order of the column. Can anybody look at my (terrible, I'm sorry) coding and see if they can help?
Private Sub UserForm_Initialize()
Dim cPart As Range
Dim cNum As Range
Dim ws As Workbook
'Dim ComboBox1 As Variant
Application.ScreenUpdating = False
Set ws = Workbooks.Open("\\Capserver\iso maintenance\CAPS MASTER PARTS & PRICE LIST 2012.xls")
Windows("CAPS MASTER PARTS & PRICE LIST 2012.xls").Visible = False
'ws.Sheets("CAPS ORDER FORM").Range("Name") = Sheet1.ComboBox1
'ComboBox1.Clear
For Each cPart In ws.Sheets("CAPS ORDER FORM").Range("Name")
With Me.cboPart
.AddItem cPart.Value
End With
Next cPart
For Each cNum In ws.Sheets("CAPS ORDER FORM").Range("Number")
With Me.cboNum
.AddItem cNum.Value
.List(.ListCount - 1, 1) = cNum.Offset(0, 1).Value
End With
Next cNum
End Sub
Private Sub cmdAdd_Click()
Dim lRow As Range
Dim lPart As Long
Dim ws As Worksheet
Dim something As Variant
Dim box As Object
Set ws = Worksheets("Sheet2")
With Worksheets(1).Range("A1:a500")
Set lRow = .Find(What:="", SearchOrder:=xlRows, SearchDirection:=xlNext, LookIn:=xlValues)
End With
'Set lRow = Range("A1")
' If VBA.IsEmpty(lRow.Value) Then
' MsgBox ("POOP!")
' Else
' Set box = lRow.End(xlDown)
' End If
'lRow = Worksheets("Sheet2").Range("A33:A37")
'ws.Cells.Find(What:="*", SearchOrder:=xlRows, (From tutorial, always returned lRow = Nothing)
' SearchDirection:=xlPrevious, LookIn:=xlValues).Row 1
lPart = Me.cboPart.ListIndex
'check for a part number
If Trim(Me.cboPart.Value) = "" Then
Me.cboPart.SetFocus
MsgBox "Please enter a part name or number"
Exit Sub
End If
'copy the data to the database
'use protect and unprotect lines,
' with your password
' if worksheet is protected
With ws
' .Unprotect Password:="password"
.Cells(lRow, 1).Value = Me.cboPart.Value
.Cells(lRow, 2).Value = Me.cboPart.List(lPart, 1)
.Cells(lRow, 3).Value = Me.cboNum.Value
' .Cells(lRow, 4).Value = Me.txtDate.Value
.Cells(lRow, 5).Value = Me.txtQty.Value
' .Protect Password:="password"
End With
'Combobox1.linkedcell=C4
'clear the data
Me.cboPart.Value = ""
Me.cboNum.Value = ""
Me.txtQty.Value = ""
Me.cboPart.SetFocus
End Sub
Private Sub cmdClose_Click()
Unload Me
End Sub
The goal is to be able to click the "Add part" button and add multiple files and have it output to the work order (I think the range for the parts is A33:A55 or something similar)
I ALSO would like to know if there is a way to make BOTH the part name AND part numbers dependent in the UserForm depending on which one you enter? Though that is a lower priority.
I'm still not 100% on what you are trying to do, and you may have some sections commented out that you may want to use (ie the combobox). Your 1row range is finding the next empty cell which I don't think you want to do. But as for how you would input the information into a range, you probably need to change your ws With statement:
1row = 35 'or whatever row number
For n =0 to CountOfItemsToAdd 'could also be done with a For Each statement
'You will also need another for statement here to go through your part list
With ws
1row = 1row + (n*3)
' .Unprotect Password:="password" [you only need this if using passwords]
.Cells(lRow, 1).Value = Me.cboPart.Value
.Cells(lRow+1, 1).Value = Me.cboPart.List(lPart, 1)
.Cells(lRow+2, 1).Value = Me.cboNum.Value
' .Cells(lRow, 4).Value = Me.txtDate.Value
.Cells(lRow+3, 1).Value = Me.txtQty.Value
' .Protect Password:="pasword"
But to awnser your specific question, you change the first value in the .Cells reference which is the row index, not the second number, which is the column index.