Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Excel VBA question
Dear all,
The following is the situation. I import a file into an excel sheet. This file contains order information. What I want my code to do, is to identify what kind of product(s) is/are ordered per order (and write this down in a column), and also to identify the unique orders (an order can consists of more then just 1 orderline). Then I want to copy only the lines marked as unique order to a second sheet. My code does this, except that it forgets to check the last row. My file looks like this : Intro(Sheet 1): contains the button that a person needs to press, this will activate a dialogue window that instructs the user to browse the folder to locate the file that needs to be imported. Master sheet (sheet 2): in this sheet all information that is being importaed is placed here first, then 2 additional columns are added to specify what kind of product is in the order, and wether it is unique or not Unique orders (Sheet 3): All unique orders from Master sheet are copied to this sheet (not all columns). The problem is that the last row in Mastersheet is skipped by the code, and thus not copied to the 3rd sheet either. Can any of you help me, I have enclosed the code. Gr, Mariam Option Explicit Private Sub cmdCancel_Click() Unload Me End Sub Private Sub cmdOK_Click() Dim strFilePath As String Dim strFileName As String Dim strTATFile As String ' Variables for sorting out the correct orderlines Dim lngRow As Long Dim lngFirstRow As Long Dim lngLastRow As Long Dim lngFinalRow As Long ' End of data Dim strOrderNumber As String Dim strPreviousOrderNumber As String Dim strProduct(1 To 5) As String Dim intProduct(1 To 5) As Integer Dim x As Integer Dim strOmschrijving As String On Error GoTo Foutje strProduct(1) = "C8AV" 'Desktop strProduct(2) = "C7AV" 'Desktop strProduct(3) = "E6AV" 'Laptop strProduct(4) = "94A" 'Monitor strProduct(5) = "A2AV" 'Laptop strTATFile = ActiveWorkbook.Name strFilePath = txtPath.Text Workbooks.Open strFilePath strFileName = ActiveWorkbook.Name Workbooks(strFileName).Sheets(1).Select Cells.Select Selection.Copy Windows(strTATFile).Activate Workbooks(strTATFile).Sheets("Master Sheet").Select Cells.Select ActiveSheet.Paste Application.DisplayAlerts = False Windows(strFileName).Close Application.DisplayAlerts = True Range("A1").Activate Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=True, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal lngRow = 2 lngFirstRow = 2 Do Until Cells(lngRow, 7).Value = "" strOrderNumber = Cells(lngRow, 7).Value If strOrderNumber = strPreviousOrderNumber Then ' Same order, more then 1 orderline ' RAise ProductCounter - ProductTeller ophogen For x = 1 To 5 If Cells(lngRow, 8).Value = strProduct(x) Then intProduct(x) = intProduct(x) + 1 End If Next x Else ' New Order - Nieuwe order lngFirstRow = lngLastRow + 1 lngLastRow = lngRow - 1 If lngFirstRow 1 Then Cells(lngFirstRow, 31).Value = "*" End If ' Test of VerwijderLoop nodig is --- Origineel 'If intProduct(1) + intProduct(2) + intProduct(3) = 0 Or intProduct(3) + intProduct(4) = 0 Then 'Verwijderen ' For x = lngFirstRow To lngLastRow '' 'Cells(x, 7).Interior.Color = vbRed 'coloured columns are marked for deletion - test purposes '' If x 1 Then '' Cells(x, 7).EntireRow.Clear '' End If '' Next x If intProduct(1) + intProduct(2) + intProduct(3) + intProduct(5) = 0 Then 'Remove - Verwijderen For x = lngFirstRow To lngLastRow 'Cells(x, 7).Interior.Color = vbRed 'coloured columns are marked for deletion - test purposes If x 1 Then Cells(x, 7).EntireRow.Clear End If Next x Else 'Writing wether this is about a desktop, laptop, or a combination of laptop/desktop. If intProduct(1) + intProduct(2) 0 Then strOmschrijving = "desktop" If intProduct(3) + intProduct(5) 0 Then strOmschrijving = "Desktop-Laptop" End If Else If intProduct(3) + intProduct(5) 0 Then strOmschrijving = "laptop" End If End If For x = lngFirstRow To lngLastRow If x 1 Then Cells(x, 30).Value = strOmschrijving End If Next x End If 'Empty ProductCounter - Leeggooien van Teller (van de producten) For x = 1 To 5 intProduct(x) = 0 Next x 'Filling up Product Counter - En daarna vullen van Teller met deze regel For x = 1 To 5 If Cells(lngRow, 8).Value = strProduct(x) Then intProduct(x) = intProduct(x) + 1 End If Next x End If strPreviousOrderNumber = strOrderNumber lngRow = lngRow + 1 Loop 'lngFinalRow = lngRow - 1 lngFinalRow = lngRow For x = lngFinalRow To 2 Step -1 If Cells(x, 7) = "" Then Cells(x, 7).EntireRow.Delete Shift:=xlUp End If Next x Cells(1, 30).Value = "Product" WriteUniqueOrders lngFinalRow Unload Me 'CreatePivotTable Exit Sub Foutje: MsgBox "File could not be opened" End Sub Sub WriteUniqueOrders(lngFinalRow As Long) Dim x As Integer Sheets("Master Sheet").Select Cells.Select Selection.Copy Sheets("Unique Orders").Select Cells.Select ActiveSheet.Paste Cells(1, 1).Select For x = lngFinalRow To 2 Step -1 If Cells(x, 31) = "" Then '30 veranderd naar 31 Cells(x, 31).EntireRow.Delete End If Next x Columns("H:I").Delete Shift:=xlToLeft Columns("AB:AB").Delete Shift:=xlToLeft CreateNames Sheets("Master sheet").Select Cells(1, 1).Select End Sub Sub CreateNames() Dim lngNumberOfRows As Long 'Label naam moet gedelete worden, foutmelding wordt gegenereerd indien er geen 'label bestaat om te deleten. met deze error handling wordt deze situatie opgevangen. 'De reden waarom het gedelete moet worden, is voor het geval deze bestaat. On Error Resume Next 'Bij foutdoorgaan met volgende regel. ActiveWorkbook.Names("UniqueOrders").Delete On Error GoTo 0 'Vanaf hier wel weer foutmeldingen lngNumberOfRows = Sheets("Unique Orders").Range("A1").CurrentRegion.Rows.Count ActiveWorkbook.Names.Add Name:="UniqueOrders", RefersToR1C1:= _ "='Unique Orders'!R1C1:R" & lngNumberOfRows & "C27" End Sub Private Function GetFileToOpenName() As String Dim BestandsNaam As String Dim File_Dialoog As FileDialog Dim Result As Long Set File_Dialoog = Application.FileDialog(msoFileDialogOpen) File_Dialoog.Filters.Clear File_Dialoog.Filters.Add "Excelworksheet (*.xls)", "*.xls", 1 Result = File_Dialoog.Show() If Result = -1 Then GetFileToOpenName = File_Dialoog.SelectedItems.Item(1) Else GetFileToOpenName = "" End If End Function Private Sub cmdOpen_Click() txtPath.Text = GetFileToOpenName End Sub |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Excel 2007 Macro/VB Question DDE Question | Excel Worksheet Functions | |||
Excel 2003 to Excel 2007 Question | Excel Worksheet Functions | |||
Newbie Question - Subtraction Formula Question | Excel Discussion (Misc queries) | |||
The question is an excel question that I need to figure out howto do in excel. | Excel Worksheet Functions | |||
Statistical Excel Function Question within Excel 2000... | Excel Worksheet Functions |