Free Microsoft Excel 2013 Quick Reference

Macro to select last row with data Results

Hello all, I am having trouble with a macro. Please see my test file for more details:
http://dl.dropbox.com/u/15735073/test.xlsm

The macro is as follows:


	VB:
	
 InsertRow() 
     
     'The following three lines of code search for the text "Total" and make it the "active cell".
     'This tells the programme automatically where to insert the cells
     
    Cells.Find(What:="Total", After:=ActiveCell, LookIn:=xlValues, LookAt:= _ 
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ 
    , SearchFormat:=False).Activate 
     
     'The following line of code moves down two cells from "CFP Data ID"
    Selection.Offset(-1, 0).Select 
    Dim Rng, n As Long, k As Long 
    Application.ScreenUpdating = False 
     
     'These two lines of code fetch the number of rows you want to insert into the sheet
    Rng = InputBox("Enter number of rows required.") 
    If Rng = "" Then Exit Sub 
     
     'This line inserts a new row
    Range(ActiveCell, ActiveCell.Offset(Val(Rng) - 1, 0)).EntireRow.Insert 
     
     'The next three lines are magic to me and these the comments here are original
     'need to know howmany formulas to copy down.
     'Assumes from A over to last entry in row.
     
    k = ActiveCell.Offset(-1, 0).Row 
    n = Cells(k, 256).End(xlToLeft).Column 
    Range(Cells(k, 2), Cells(k + Val(Rng), n)).FillDown 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I have annotated it slightly. So I can insert new cells and copy the formulas with no problem. However each row needs to have its own "Data ID". When using the macro as it is I just get endless repeats of e.g. "C0013". How can I get my macro to fill the "B" column correctly.

One thing that is really important to me is that this macro will be used in different sheets in the same spreadsheet. the "Data ID" might in one sheet be in B6, in other sheets it might be in B22 etc.

Any support would be greatly appreciated!

Hi All,

Firstly, this forum has been a great help to me learning VBA over the last couple of weeks, so thank-you to you all for your questions and answers.

I've run into a wall debugging my first large VBA project; Ive done a pretty thorough search, and while I found a few similar problems, none of the solutions have helped my particular error.

The code is designed to filter a large list of clients based on the value of the Activecell, which is in column F: containing Medical Practice names.

After filtering, the code creates a new sheet, pastes the filtered values there, and then starts to format them. This is where the problem occurs. I suspect it's due to the liberal use of "Active" sheets and books and cells throughout the code, but I can't be sure.

Here's the troublesome part, and I'll post the full code below. The debugger points to the first "If" line, line 7 of this sample.


	VB:
	
 
Set WSLoop = Sheets("New Patient List") 
WSNewRows = WSLoop.UsedRange.Count 
CellA = 4 
CellB = 4 
 
For CellA = 4 To WSNewRows 
    CellB = CellA + 1 
    If WSLoop.Range(Cells(CellB, 5)).Value = WSLoop.Range(Cells(CellA, 5)).Value Then 
        If WSLoop.Range(Cells(CellA, 5)).Interior.Colourindex = 35 Then 
            WSLoop.Range(Cells(CellB, 1), Cells(CellB, 6)).Interior.ColorIndex = 35 
        Else 
            WSLoop.Range(Cells(CellB, 1), Cells(CellB, 6)).Interior.ColorIndex = 34 
        End If 
    Else 
        If WSLoop.Range(Cells(CellA, 5)).Interior.Colourindex = 35 Then 
            WSLoop.Range(Cells(CellB, 1), Cells(CellB, 6)).Interior.ColorIndex = 34 
        Else 
            WSLoop.Range(Cells(CellB, 1), Cells(CellB, 6)).Interior.ColorIndex = 35 
        End If 
    End If 
Next CellA 
 
End If 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
The full code (minus some of the detailed comments from Mr De Bruin and myself; let me know if they would help) is thus:


	VB:
	
 
Sub GP_Filter_to_new_WS() 
     'Code by Ron de Bruin (last update 27-July-2010)
     'with modification and additions by Evan Tunbridge 13/5/2011
     
    Dim My_Range As Range 
    Dim ParentSheet As Worksheet 
    Dim ProviderName As Object 
    Dim WSNewRows As Integer 
    Dim WSLoop As Worksheet 
    Dim CellA As Integer 
    Dim CellB As Integer 
    Dim CalcMode As Long 
    Dim ViewMode As Long 
    Dim FilterCriteria As String 
    Dim CCount As Long 
    Dim WSNew As Worksheet 
    Dim sheetName As String 
    Dim rng As Range 
     
     'Remember the Active Worksheet, to unhide columns etc at the end
    Set ParentSheet = ActiveSheet 
     
     'Remember the Provider Name, it should be the active cell when the Macro starts
    Set ProviderName = ActiveCell 
     
    Set My_Range = Range("A3:H" & LastRow(ActiveSheet)) 
    My_Range.Parent.Select 
    If ActiveWorkbook.ProtectStructure = True Or _ 
    My_Range.Parent.ProtectContents = True Then 
        MsgBox "Sorry, not working when the workbook or worksheet is protected", _ 
        vbOKOnly, "Copy to new worksheet" 
        Exit Sub 
    End If 
     'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application 
        CalcMode = .Calculation 
        .Calculation = xlCalculationManual 
        .ScreenUpdating = False 
        .EnableEvents = False 
    End With 
    ViewMode = ActiveWindow.View 
    ActiveWindow.View = xlNormalView 
    ActiveSheet.DisplayPageBreaks = False 
     
     'Firstly, remove the AutoFilter
    My_Range.Parent.AutoFilterMode = False 
     
     'Filter and set the filter field and the filter criteria :
     'This line filter on the 6th column in the range (change the field if needed)
     'In this case the range starts in A so Field 1 is column A, 6 = column F, ......
     'My_Range.AutoFilter Field:=6, Criteria1:="=Dellwood Medical Centre"
     'If you want to filter on a cell value you can use this, use "" for the opposite
     
     'This line uses the "ProviderName" Variable, which we assigned the Active Cell to
    My_Range.AutoFilter Field:=6, Criteria1:="=" & ProviderName 
     
     'Now Hides the columns that should not be copied to the new sheet
     'to be sent to providers Such as dates notified, provider names, etc.
     
    ActiveSheet.Columns("F:G").Hidden = True 
    ActiveSheet.Columns("I:T").Hidden = True 
     
     'Check if there are not more then 8192 areas(limit of areas that Excel can copy)
    CCount = 0 
    On Error Resume Next 
    CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count 
    On Error Goto 0 
    If CCount = 0 Then 
        MsgBox "There are more than 8192 areas:" _ 
        & vbNewLine & "It is not possible to copy the visible data." _ 
        & vbNewLine & "Tip: Sort your data before you use this macro.", _ 
        vbOKOnly, "Copy to worksheet" 
    Else 
         'Add a new Worksheet
        Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index)) 
        On Error Resume Next 
        WSNew.Name = "New Patient List" 
        If Err.Number > 0 Then 
            MsgBox "Change the name of sheet : " & WSNew.Name & _ 
            " manually after the macro is ready. The sheet name" & _ 
            " you fill in already exists or you use characters" & _ 
            " that are not allowed in a sheet name." 
            Err.Clear 
        End If 
        On Error Goto 0 
         
         'Copy/paste the visible data to the new worksheet
        My_Range.Parent.AutoFilter.Range.Copy 
        With WSNew.Range("A3") 
            .PasteSpecial Paste:=8 
            .PasteSpecial xlPasteValues 
            .PasteSpecial xlPasteFormats 
            Application.CutCopyMode = False 
            .Select 
        End With 
         
        With WSNew.Range("A1:F1") 
            .MergeCells = True 
            .Value = ProviderName & " - Current Patients" 
            .HorizontalAlignment = xlCenter 
            .VerticalAlignment = xlCenter 
            .Font.Size = 18 
            .Font.Name = "Arial" 
            .Interior.Color = RGB(192, 192, 192) 
        End With 
         
         
         'Applying finishing touches to the New Patient List sheet;
         'including formatting, heading, etc
         
         'Sets first row of data fill as Light Green
        WSNew.Range("A4:F4").Interior.ColorIndex = 35 
         
         'The below lines format the pasted data values based on the addresses (Col F of new sheet);
         'They test if the second entry's address (F5) is the same as the one above it
         'and if it is, gives it the same colour. If its different, then gives it
         'another colour. This repeats for all subsequent rows.
         
        Set WSLoop = Sheets("New Patient List") 
        WSNewRows = WSLoop.UsedRange.Count 
        CellA = 4 
        CellB = 4 
         
        For CellA = 4 To WSNewRows 
            CellB = CellA + 1 
            If WSLoop.Range(Cells(CellB, 5)).Value = WSLoop.Range(Cells(CellA, 5)).Value Then 
                If WSLoop.Range(Cells(CellA, 5)).Interior.Colourindex = 35 Then 
                    WSLoop.Range(Cells(CellB, 1), Cells(CellB, 6)).Interior.ColorIndex = 35 
                Else 
                    WSLoop.Range(Cells(CellB, 1), Cells(CellB, 6)).Interior.ColorIndex = 34 
                End If 
            Else 
                If WSLoop.Range(Cells(CellA, 5)).Interior.Colourindex = 35 Then 
                    WSLoop.Range(Cells(CellB, 1), Cells(CellB, 6)).Interior.ColorIndex = 34 
                Else 
                    WSLoop.Range(Cells(CellB, 1), Cells(CellB, 6)).Interior.ColorIndex = 35 
                End If 
            End If 
        Next CellA 
         
    End If 
     
     'Close AutoFilter, unhide the columns on the starting Worksheet
    My_Range.Parent.AutoFilterMode = False 
    ParentSheet.Columns("F:G").Hidden = False 
    ParentSheet.Columns("I:T").Hidden = False 
     
     'Restore ScreenUpdating, Calculation, EnableEvents, ....
    My_Range.Parent.Select 
    ActiveWindow.View = ViewMode 
    If Not WSNew Is Nothing Then WSNew.Select 
    With Application 
        .ScreenUpdating = True 
        .EnableEvents = True 
        .Calculation = CalcMode 
    End With 
     
End Sub 
 
Function LastRow(sh As Worksheet) 
    On Error Resume Next 
    LastRow = sh.Cells.Find(What:="*", _ 
    After:=sh.Range("A1"), _ 
    Lookat:=xlPart, _ 
    LookIn:=xlValues, _ 
    SearchOrder:=xlByRows, _ 
    SearchDirection:=xlPrevious, _ 
    MatchCase:=False).Row 
    On Error Goto 0 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Let me know if I can provide any other details or information. If it would help, I'll try to put together a dummy spreadhseet that duplicates the format and data of the sheets I'm working with; I cant really send the sheet, as it contains names and addresses, etc.

Thanks in advance!

I am trying to append about 15 files of CSVs. I have code that works on importing the data, placing it at the end of the previous data, but then it clears the previous data.

Here is the code

	VB:
	
 import_BCDV() 
     '
     ' import_BCDV Macro
     '
    Dim lastrow As String 
     
     '
    Selection.End(xlDown).Select 
    Selection.End(xlUp).Select 
     'Range("A515").Select
    lr = FindLastrow1() 
    lastrow = "A" & lr 
    MsgBox lastrow 
    Range(lastrow).Select 
     '    "TEXT;J:QA ReportsQA ReportsWorkbenchBCVD 1-11-09 1-17-09.csv", _
     
     
     
     
     
     
    Call DoTheImport(lastrow, "J:QA ReportsQA ReportsWorkbenchBCVD 1-11-09 1-17-09.csv", "BCVD 1-11-09 1-17-09") 
    Selection.End(xlDown).Select 
    Selection.End(xlUp).Select 
    lr = FindLastrow1() 
    lastrow = "A" & lr 
    MsgBox lastrow 
    Range(lastrow).Select 
    Call DoTheImport(lastrow, "J:QA ReportsQA ReportsWorkbenchBCVD 1-11-09 1-17-09.csv", "BCVD 1-11-09 1-17-09") 
    Selection.End(xlDown).Select 
    Selection.End(xlUp).Select 
    lr = FindLastrow1() 
    lastrow = "A" & lr 
    MsgBox lastrow 
    Range(lastrow).Select 
    Call DoTheImport(lastrow, "J:QA ReportsQA ReportsWorkbenchBCVD 1-18-09 1-25-09.csv", "BCVD 1-18-09 1-25-09") 
    Selection.End(xlDown).Select 
    Selection.End(xlUp).Select 
    lr = FindLastrow1() 
    lastrow = "A" & lr 
    MsgBox lastrow 
    Range(lastrow).Select 
     
     'BCVD 1-25-09 1-31-09.csv
     'BCVD 1-4-09 1-11-09.csv
     'BCVD 12-28-08 1-3-09.csv
     'BCVD 2-1-09 2-7-09.csv
     'BCVD 2-15-09 2-21-09.csv
     'BCVD 2-22-09 2-28-09.csv
     'BCVD 2-8-09 2-14-09.csv
     'BCVD 3-1-09 3-7-09.csv
     'BCVD 3-15-09 3-21-09.csv
     'BCVD 3-22-09 3-28-09.csv
     'BCVD 3-29-09 4-4-09.csv
     'BCVD 3-8-09 3-14-09.csv
     'BCVD 4-11-09 4-17-09.csv
     'BCVD 4-18-09 4-28-09.csv
     'BCVD 4-4-09 4-11-09.csv
     
     
     
End Sub 
Sub DoTheImport(lastrow As String, Filename As String, fname As String) 
    MsgBox lastrow 
     ' .RefreshStyle = xlInsertDeleteCells
    With ActiveSheet.QueryTables.Add(Connection:= _ 
        "TEXT;" & Filename, _ 
        Destination:=Range(lastrow)) 
        .Name = fname 
        .FieldNames = True 
        .RowNumbers = False 
        .FillAdjacentFormulas = False 
        .PreserveFormatting = True 
        .RefreshOnFileOpen = False 
        .RefreshStyle = xlInsertEntireRows 
        .SavePassword = False 
        .SaveData = True 
        .AdjustColumnWidth = True 
        .RefreshPeriod = 0 
        .TextFilePromptOnRefresh = False 
        .TextFilePlatform = 437 
        .TextFileStartRow = 1 
        .TextFileParseType = xlDelimited 
        .TextFileTextQualifier = xlTextQualifierDoubleQuote 
        .TextFileConsecutiveDelimiter = False 
        .TextFileTabDelimiter = True 
        .TextFileSemicolonDelimiter = False 
        .TextFileCommaDelimiter = True 
        .TextFileSpaceDelimiter = False 
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 2, 2, 1, _ 
        2, 2, 2, 2, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1,
1 _ 
        , 1, 1, 1, 1, 1, 1, 1, 1, 1, 1) 
        .TextFileTrailingMinusNumbers = True 
        .Refresh BackgroundQuery:=False 
    End With 
End Sub 
 
 
 
Function FindLastrow1() 
     
    With ActiveSheet.UsedRange 
        MyUsedRange = .Address 
        nUsedRows = .Rows.Count 
        nUsedCols = .Columns.Count 
        lastrow = .Rows(nUsedRows).Row 
        lastrow = lastrow 
        lastCol = "a" ' .Columns(nUsedCols).Column
    End With 
    MsgBox lastrow 
    FindLastrow1 = lastrow 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I have also tried to do this manually, and at first it seemed to import OK, but after like the third set, it again clears the previous data.
What am I missing?

Would it be better to read this in line by line?
How would I do that in excel VBA?

Thanks

Hi there,

I've gone through the search function on the forum a few times to try and find a solution, but I'm struggling to find an appropriate answer - it may just be I can't ask the search the right question.

Having read through the help section and warnings a few times, I hope I'm not going to upset anyone with my 1st post...

My situation is as follows. I have one master sheet of data, with a large number of fields and data.

I need to turn this master data into individual records, each record exisiting as an individual worksheet - lets call it a 'U'. The U is a template sheet which has calculations and lookups built into it to complete further information. The completed U's are then used by a number of people for different reasons. There are 3 main 'flavours' of these sheets which have slightly different uses.

I've gone from knowing nothing about macros to having learned enough about them in the last week or so to populate each individual sheet with the data, and save the new file in the location I want it to go.

What I want to do now is filter the fields displayed by the individual U sheets, as not every field is applicable to each 'flavour'. I've marked up the rows as to the appropriate flavour - e.g. Row 17 is applicable to 'P' 'F' and 'R' (Cell which is auto filtered contains PFR), but Row 18 is only 'P' and 'F' (Cell contains PF).

I've gone through the master file and identified each entry as a the appropriate flavour - to summarise what I'd like to do now:

1) Automatically populate the template file with the relevant data. (which my macro will do)
2) Use an autofilter to filter the rows equal to the data in the reference sheet so these are the only ones displayed. Eg. Reference sheet says 'P', so I want to filter the U sheet where autofilter column contains the letter 'P'
3) Rename the file and save as my reference in the location I want it to (which the macro is doing).

Here's what I've got:

	VB:
	
Range("CF3").Select 
Selection.Copy 
Windows("USS iss1.xls").Activate 
Range("G158").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
:=False, Transpose:=False 
Selection.AutoFilter Field:=1, Criteria1:=ActiveCell, Operator:=xlAnd 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
(where CF3 = the cell in the master data with the flavour in it, "USS iss1" is the template U file, G158 is a spare cell and Autofilter Field 1 contains the row reference which tells me which data applies to which flavours).

I've tried using the macro recorder, which when I paste the value in the autofilter/contains box records it as the value I've just put in rather than a copy of the reference cell. I've tried

	VB:
	
Criteria1:=*ActiveCell* 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
and other variations on the same theme, but to no avail - I get "Compile error: Expected:expression".

Once again, I hope i've not fallen foul of the forum rules, and I'm conscious I've waffled on too much with my explanation. I'd really appreciate any assistance on this subject that is out there...

Matt

I'm having difficulty writing a macro to automate this task. Please don't laugh ... I'm pretty new at this! A lot of the code below is a result of researching various forums in an effort to piece something together.

What I'm trying to do is check each Row and move the last 3 Columns of data in each Row to the left so they fall under the headings NHA2, NHA1, and OEM PN (Columns U, V, and W).

Columns A and B are temporary. Column A utilizes the formula "=COUNTA(B2:AG2)" to count the number of cells in the row that contain data. Column B utilizes the formula "=COUNTA(C:C)" to count the total rows of data in the active worksheet. Columns A and B will be deleted at the end of the Macro.

The GOAL (END RESULT) is for Columns A through W (and ONLY these Columns) to contain data (keeping in mind that Columns A and B will be deleted at the end).

If some rows have Column W (and beyond) blank, then I want to MOVE data from Columns U & V over to V & W and then COPY data from Column T into the [currently] blank Column U.

I've been trying to get the Macro to start in the last row and, using CASE Statements, delete the proper range of cells and SHIFT LEFT as it counts backwards towards the first row. I'm not too sure this is the best approach and could really use some advice from the experts!

I can provide a "test" file if necessary ... the test file I've been working with is approximately 6.5MB, but I can delete most of the 14,287 rows and still give a good representation of how the data varies.

I'd like to thank everyone that's made the information on this site available, as it's been extremely helpful thus far!

And I appreciate any help anyone can send my way!

My current NON-WORKING code is below.

THANKS!!!


	VB:
	
 b_DeleteCellsShiftLeft() 
     
     ' DeleteShiftLeft Macro
     ' Macro recorded 3/14/2007 by George Nicholaou
     
     ' Need to assign variable for current row (?)
     ' r=ROW()
     
     ' Columns A and B are temporary
     ' Column A utilizes the formula "=COUNTA(B2:AG2)" to count the number of cells in
     ' the row that contain data
     ' Column B utilizes the formula "=COUNTA(C:C)" to count the total rows of data
     ' in the active worksheet
     ' They will be deleted at the end of the Macro
     ' What I want the Macro to do from this point is:
     ' 1. Check each Row and move the last 3 Columns of data in each Row to the left so
     '    they fall under the headings NHA2, NHA1, and OEM PN (Columns U, V, and W)
     ' 2. The GOAL (END/RESULT) is for Columns A through W (and ONLY these Columns)
     '    to contain data (keep in mind, Columns A and B will be deleted at the end)
     ' 3. If some rows have Column W blank, then MOVE data from Columns U & V over to V & W
     '    AND THEN COPY data from Column T into the [currently] blank Column U.
     
     ' How I've been trying to accomplish this:
     ' I've been trying to get the Macro to start in the last row and, using CASE Statements,
     ' delete the proper cells and SHIFT LEFT as it counts backwards towards the first row
     
     ' TURN AUTO SCREEN UPDATING AND AUTO CALCULATION OFF
    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 
     
    Dim rng As Range, i As Long 
    Dim iTotalRows As Integer 
    iTotalRows = Range("B1").Value 
     
     ' Set the range to evaluate to rng
    Set rng = Intersect(Selection, ActiveSheet.UsedRange) 
     ' Set rng = Intersect(Selection, Range("A:A"), ActiveSheet.UsedRange)
     ' If rng Is Nothing Then
     '    MsgBox "nothing in Intersected range to be checked"
     '    GoTo done
     ' End If
     
     ' Loop backwards through the rows in the range that you want to evaluate.
    For i = rng.Rows.Count To 1 Step -1 
         ' For i = rng.Count To 1 Step -1
         
         ' [I think] This needs to start at the end (bottom/last row) of the Active Workbook
         ' Select the applicable Case Statement and perform corresponding action
         
        Select Case Range("A" & iTotalRows & "").Value 
        Case 31 
            Range("U:AD").Select 
            Selection.Delete Shift:=xlToLeft 
        Case 30 
            Range("U:AC").Select 
            Selection.Delete Shift:=xlToLeft 
        Case 29 
            Range("U:AB").Select 
            Selection.Delete Shift:=xlToLeft 
        Case 28 
            Range("U:AA").Select 
            Selection.Delete Shift:=xlToLeft 
        Case 27 
            Range("U:Z").Select 
            Selection.Delete Shift:=xlToLeft 
        Case 26 
            Range("U:Y").Select 
            Selection.Delete Shift:=xlToLeft 
        Case 25 
            Range("U:X").Select 
            Selection.Delete Shift:=xlToLeft 
        Case 24 
            Range("U:W").Select 
            Selection.Delete Shift:=xlToLeft 
        Case 23 
            Range("U:V").Select 
            Selection.Delete Shift:=xlToLeft 
        Case 22 
            Range("U").Select 
            Selection.Delete Shift:=xlToLeft 
             ' Case 21
             ' DO NOTHING ... THIS IS WHERE WE WANT THE DATA
             ' Case 20
             ' Then do something ...
             ' I'm not sure how to set a variable to address "CurrentRow"
             ' Range("U[CurrentRow]:V[CurrentRow]").Select
             ' Selection.Cut Destination:=Range("V[CurrentRow]:W[CurrentRow]")
             ' Range("T[CurrentRow]").Select
             ' Selection.Copy
             ' Range("U[CurrentRow]").Select
             ' ActiveSheet.Paste
        End Select 
         
         ' Does this move up to the next row?
    Next 
     
     ' done:
     
     
     ' THE FOLLOWING ACTIONS ARE TURNED OFF FOR TESTING PURPOSES
     ' Turn AUTO SCREEN UPDATING and AUTO CALCULATION back ON
     ' Application.ScreenUpdating = True
     ' Application.Calculation = xlCalculationAutomatic
     ' Delete Columns A & B and return to Cell A1
     ' Columns("A:B").Select
     ' Selection.Delete Shift:=xlToLeft
     ' Range("A1").Select
     ' SAVE the active worksheet
     ' ActiveWorkbook.Save
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hi again,
I thank Norie for solving my problem in the thread "Type Mismatch Error Message".
Now a new problem has come up in the same code, so - according to the rules - I've started a new thread.
(This one is most likely due to my poor knowledge of VBA syntax - sorry about that).

Here is the last version of the code:


	VB:
	
 Delete_invalid_rows() 
    Dim i%, j% 
    Dim Nr%, valid As Boolean, BYPdata As Boolean 
    Dim ar1 As Variant 
    Dim ar2 As Variant 
    Dim ar3 As Variant 
    Dim ar4 As Variant 
     
    Nr = 20 
     
    ar1 = Array(11, 14, 19, _ 
    20, 22, 25, 26, 27, 28, 29, _ 
    30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, _ 
    41, 42, 43, 44, 45, 46, 47, 48, 49, _ 
    50, 51, 52, _ 
    64, 65, 66, 68, 69, _ 
    70, 71, 72, 73, 74, 75, 76, 77, 79, _ 
    80, 81, 82, 83, 84, 85, 86, 87, 88, 89, _ 
    90, 91, 92, 93, 94, 95, 96, 97, _ 
    104, 106, 107, 109, 112, 116, _ 
    126, 127, 128, 129, _ 
    131, 133, 134, 135, 136, 137, 138, 139, _ 
    140, 142, 143, 145) 
     
    ar2 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, _ 
    10, 12, 13, 15, 16, 17, 18, _ 
    21, 23, 24, _ 
    53, 54, 55, 56, 57, 58, 59, _ 
    61, 62, 67, 78, 98, 99, _ 
    100, 101, 102, 103, 105, 108, _ 
    110, 111, 117, 119, _ 
    132, _ 
    141, 144, 146) 
     
    ar3 = Array(113, 114, 115, 118, 120, 121, 122, 123, 124, 125) 
     
    ar4 = Array(149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160) 
     
    For i = 5 To Nr 
        valid = True 
         
        For j = 1 To UBound(ar1) 
            If IsError(ActiveSheet.Cells(i, ar1(j)).Value) Then valid = False 
        Next j 
         
        For j = 1 To UBound(ar2) 
            If IsError(ActiveSheet.Cells(i, ar2(j)).Value) Then valid = False Else 
            If ActiveSheet.Cells(i, ar2(j)).Value = 0 Then valid = False 
        Next j 
         
        For j = 1 To UBound(ar3) 
            If Not IsError(ActiveSheet.Cells(i, ar3(j)).Value) Then _ 
            If ActiveSheet.Cells(i, ar3(j)).Value = 0 Then valid = False 
        Next j 
         
        BYPdata = False 
         
        For j = 1 To UBound(ar4) 
            If Not IsError(ActiveSheet.Cells(i, ar4(j)).Value) Then _ 
            If ActiveSheet.Cells(i, ar4(j)).Value  0 Then BYPdata = True 
        Next j 
         
        If Not (BYPdata) Then valid = False 
         
        If Not (valid) Then 
            Rows(i).Select 
            Selection.Delete Shift:=xlUp 
             'i = i - 1
             'Nr = Nr - 1
        End If 
    Next i 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
The lines:


	VB:
	
 'Nr = Nr - 1

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
(which are currently deactivated), should do the following things:

- when a row is deleted and the rest of the data is shifted 1 row up, the
total number of rows should be decreased by one (Nr=Nr-1)

- at the same time, since row i has been deleted and row i+1 has taken its place, the nex time the counter is incremented it will actually examine what originally was row i+2. That is, each time a row is deleted, the following row is skipped. This is the reason for statement i=i-1.

Now, if you try to activate Nr=Nr-1, you'll se that nothing changes, the program will still go through the original number of rows.
And if you try to activate i=i-1, you'll se that the program will loop indefinitely, deleting all rows.

So, I think these are not the correct things to write inside a For - Next loop, but I don't know if the problem is due to wrong syntax or to the way a For - Next loop works...

I'm also joining a file with a data set ant the macro Delete_invalid_rows().

Thanks in advance for any help,

Gab

Dear Gurus:

I need assistance with Step 2 below:

1. I created a "Top Category Data Dependent Validation List for sub-categories” in the attached spreadsheet. The selection from the Category drop-down list in column B, then drives or limits the choices in the Sub-category drop-down list in column C.

Credits: To achieve the above technique, I used the "Dependent List Validation" document as a technical reference.
the document is available from http://www.ozgrid.com/Excel/dependent-lists.htm

2. If the user updates the Category selection in Column B, then the value in the corresponding row in Column C should be "reset to a (NULL/Clear) value," as to automatically prevent any human-error in forgetting to also update the Sub-category data in Column C.

Any tips in achieving Step 2 would be greatly appreciated!

Thanks much in advance for your time and help,
Jocelyn

(Optional Reading--the following steps are not related to steps 1 & 2 above, just notes regarding other data validation process created in this spreadsheet

3. I also created another column (D) that gets automatically populated with the Category ID,
based on the sub-category drop-down list selection in C.

4. Also in this spreadsheet, a macro checks for any "missing required data
before allowing the end-user to save this worksheet. As an example, In Column A, if there is a "RecordId" that exists in the same row, then the macro checks if the user has entered required values in Column B, C, "AND/OR" D. If the end-user did not enter any of the required values,
then an error message pops-up with this message:

"Cannot Save this file due to Missing Required Data. Please review highlighted record and complete missing data."

Credits:

Special thanks to:
-OzGrid Business Applications for writing code for a UDF (function that returns last word) that I used/modified a little bit to achieve Step 3.

-Carl (member name" carlmack") for his help in the methods I used in Step 4 above.

Hi everyone,

Ive used this site a few times already but this is my first post. I would be greatfull if anyone can help me out here. I have macro that searches for an item in a workbook, It finds it no problem at all. the problem i am having is getting the information i have entered on a form, to display on the worksheet on the same row as the searched item.
For example, i search for an item and i is highlighted on whatever row it is, for argument sake it might be A55 on sheet 3, the next 6 columns already contain information, what i now want to do is enter information in columns 7 through to 11 according to what i enter in the form.

I have tried various different things, some of which have resulted in the data being placed on row 1 instead of the same row as the searched for item.

This is what i have so far.

	VB:
	
 OK_Click() 
     
    Dim ThisAddress$, Found, FirstAddress 
    Dim Lost$, N&, NextSheet& 
    Dim CurrentArea As Range, SelectedRegion As Range 
    Dim Reply As VbMsgBoxResult 
    Dim FirstSheet As Worksheet 
    Dim Ws As Worksheet 
    Dim Wks As Worksheet 
    Dim Sht As Worksheet 
     
    Set FirstSheet = ActiveSheet '< bookmark start sheet
    Lost = medref.Value 
    If Lost = Empty Then End 
    For Each Ws In Worksheets 
        Ws.Select 
        With ActiveSheet.Cells 
            Set FirstAddress = .FIND(What:=Lost, LookIn:=xlValues) 
            If FirstAddress Is Nothing Then '< blank sheet
                Goto NextSheet 
            End If 
            FirstAddress.CurrentRegion.Select 
            Selection.Interior.ColorIndex = 6 '< yellow
             '//colour the 'Lost' font red, cell colour blank
            With Selection 
                Set Found = .FIND(What:=Lost, LookIn:=xlValues) 
                If Not Found Is Nothing Then 
                    FirstAddress = Found.Address 
                    Do 
                        Found.Interior.ColorIndex = 3 '< red
                        Found.Font.Bold = True 
                        Found.Font.ColorIndex = 2 
                        Set Found = .FindNext(Found) 
                    Loop While Not Found Is Nothing And Found. _ 
                    Address  FirstAddress 
                End If 
            End With 
            Reply = MsgBox("Is this the " & Lost & " you're looking for?", _ 
            vbQuestion + vbYesNoCancel, "Current Region") 
             '//restore the 'Lost' font and cell colour
            Set Found = .FIND(What:=Lost, LookIn:=xlValues) 
            If Not Found Is Nothing Then 
                FirstAddress = Found.Address 
                Do 
                    Found.Font.Bold = False 
                    Found.Font.ColorIndex = 0 
                    Set Found = .FindNext(Found) 
                Loop While Not Found Is Nothing And Found. _ 
                Address  FirstAddress 
            End If 
             '//restore the selection colour
            Selection.Interior.ColorIndex = xlNone 
            Set FirstAddress = .FIND(What:=Lost, LookIn:=xlValues) 
            If Reply = vbCancel Then End 
             '//dont look further
            If Reply = vbYes Then 
                Set SelectedRegion = Selection 
                Found.Select 
                 
Goto Finish: 
            End If 
             '//case=not this one
            ThisAddress = FirstAddress.Address 
            Set CurrentArea = Selection 
            Do 
                If Intersect(CurrentArea, Selection) Is Nothing Then 
                    With Selection.Interior 
                        .ColorIndex = 6 
                        .Pattern = xlSolid 
                    End With 
                     '//colour the 'Lost' font red, cell colour blank
                    With Selection 
                        Set Found = .FIND(What:=Lost, LookIn:=xlValues) 
                        If Not Found Is Nothing Then 
                            FirstAddress = Found.Address 
                            Do 
                                Found.Interior.ColorIndex = 3 
                                Found.Font.Bold = True 
                                Found.Font.ColorIndex = 2 
                                Set Found = .FindNext(Found) 
                            Loop While Not Found Is Nothing And Found. _ 
                            Address  FirstAddress 
                        End If 
                    End With 
                    Reply = MsgBox("Is this the " & Lost & " you're looking for?", _ 
                    vbQuestion + vbYesNoCancel, "Current Region") 
                     '//restore the 'Lost' font and cell colour
                    Set Found = .FIND(What:=Lost, LookIn:=xlValues) 
                    If Not Found Is Nothing Then 
                        FirstAddress = Found.Address 
                        Do 
                            Found.Font.Bold = False 
                            Found.Font.ColorIndex = 0 
                            Set Found = .FindNext(Found) 
                        Loop While Not Found Is Nothing And Found. _ 
                        Address  FirstAddress 
                    End If 
                     '//restore the selection colour
                    Selection.Interior.ColorIndex = xlNone 
                    Set FirstAddress = .FIND(What:=Lost, _ 
                    LookIn:=xlValues) 
                    If Reply = vbCancel Then End 
                    If Reply = vbYes Then 
                        Set SelectedRegion = Selection 
Goto Finish: 
                    End If 
                End If 
                If CurrentArea Is Nothing Then 
                    Set CurrentArea = Selection 
                Else 
                    Set CurrentArea = Union(CurrentArea, Selection) 
                End If 
                Set FirstAddress = .FindNext(FirstAddress) 
                FirstAddress.CurrentRegion.Select 
            Loop While Not FirstAddress Is Nothing And FirstAddress. _ 
            Address  ThisAddress 
        End With 
NextSheet: 
    Next Ws 
Finish: 
    If Reply = vbYes Then 
        Exit Sub 
    Else 
        FirstSheet.Select 
        MsgBox "Search Completed - Sorry, no more " & Lost & "s", _ 
        vbInformation, "No Region Selected" 
    End If 
     
    Dim lRow As Long 
    Dim lPart As Long 
    Set Ws = ActiveSheet 
    Dim c As Long 
     
    ActiveCell.Select 
     
     'check for a part number
    If Trim(Me.serial.Value) = "" Then 
        Me.serial.SetFocus 
        MsgBox "Please enter a Serial number" 
        Exit Sub 
    End If 
     
     
    With Ws 
         
        Cells(r, 7).Value = Me.serial.Value 
        r = ActiveCell.Column 
        Cells(r, 8).Value = Me.rankname.Value 
        r = ActiveCell.Column 
        Cells(r, 9).Value = Me.unit.Value 
        r = ActiveCell.Column 
        Cells(r, 10).Value = Me.data.Value 
        r = ActiveCell.Column 
        Cells(r, 11).Value = Me.datepicker.Value 
        .Cells(lRow, 6).Value = Me.datepicker.Value 
         
         
    End With 
     'clear the data
    Me.serial.Value = "ENTER" 
    Me.rankname.Value = "SELECT" 
    Me.unit.Value = "ENTER" 
    Me.data.Value = "ENTER" 
    Me.serial.SetFocus 
     
    Issue.Hide 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

Any help would be appreciated.

Hey, I am doing an invoice and booking "system" using excel 2000.

How it works: You fill out a form, (in the process, filling out customer details, eg name, address, phone # etc... and selecting items to rent) and then calculate the total price (certain discounts and deposits apply). This I have done.

Now what I need to do is export certain data from the invoice into a data table in another sheet (using a macro). I know what data to export and where I want it. The trouble I'm having is:
I want to copy the data from certain cells, then paste it into the corresponding field within a table in the other sheet. The table starts out as 1 row. Each booking has an order number. Obviously this starts at one. The macro should copy all the data (the current method is, to select the cell, right click, copy, go to new cell right click, paste special, "values") from the appropriate cells (the data in the invoice is in different tables, it isnt all adjecent) and then in the other sheet, it should create a new row and insert the data (theres about 5-6 fields). The new table needs to sort all entries by the order number (displaying the most recent booking at the top).

Each customer has a unique ID #. Another thing I would like to do once the macro is done, is on the invoice sheet, automatically set the order number as 1 more than the last in the bookings table.

This should be possible, and I know it wouldn't be extremely difficult, but I need help with this quite urgently. I hope not to sound rude or impatient but a speedy response would be much appreciated. Thanks in advance :D

If you need any more info to help understand what is needed, just ask

Thanks.

Hello,
I have a situation where I have an msg box pop up that asks the user to identify whether or not the file they have chosen meets the standards needed to continue running the macro. Specifically, I need them to answer "Yes" if the file has a list of data in the first column, if there are no blanks in that list and if the first row of data begins on Row 4. If they answer yes, the macro continues ahead and does what it needs to. If the person selects "no," another input box pops up that asks the user to make the edits. This msg box asks the user to click "ok" when they have made those edits. I want the macro to pause after the person has selected "no" from the first msg box, so that the person can make those corrections. Then, I want the macro to resume when the user selects "OK" on the second msg box. How might I do this?
I have included the piece of my code below.

	VB:
	
strresponse2 = MsgBox("Please confirm that the file you have selected meets the following standards:" & vbNewLine & "1.
The information in the first column of this file is all of the job titles or job codes associated with this profile." &
vbNewLine & "2. From the first job code or title to the last, there are no blank rows in this first column of data." &
vbNewLine & "3. The first job title or code appears on Row 4, Column 1." & vbNewLine & "If the file you selected meets these
standards, select Yes. If the file you selected does not meet these requirements, select No.", vbYesNo, "Yes/No") 
If strresponse = 6 Then 
    Call getjobtitle 
End If 
If strresponse = 7 Then 
     'pause macro
    strresponse2 = MsgBox("Please make the necessary edits to this file. When you are done, select OK to continue generating
your job profile.", vbOKOnly, "OK") 
    If strresponse = 0 Then 
         'resume macro
        Call getjobtitle 
    End If 
End If 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hi,

I have seen this problem mentioned on other threads, but, didn't see the resolution. I got the below code from contextures.com's sample spreadsheet DataValComboBoxSheet.xls. When I press the tab or enter key, Excel crashes. This macro does exactly what I need which is to allow the user to autocomplete from a long list of validation values that come from another spreadsheet. The code causing the crash is the Select Case KeyCode statement when the keycode is 9 or 13. I am running Excel 2002.


	VB:
	
 
 
Private Sub TempCombo_KeyDown(ByVal _ 
    KeyCode As MSForms.ReturnInteger, _ 
    ByVal Shift As Integer) 
     'Hide combo box and move to next cell on Enter and Tab
    Select Case KeyCode 
    Case 9 
        ActiveCell.Offset(0, 1).Activate 
    Case 13 
        ActiveCell.Offset(1, 0).Activate 
    Case Else 
         'do nothing
    End Select 
End Sub 
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 
    Dim str As String 
    Dim cboTemp As OLEObject 
    Dim ws As Worksheet 
    Dim wsList As Worksheet 
    Set ws = ActiveSheet 
    Set wsList = Sheets("ValidationLists") 
    Cancel = True 
    Set cboTemp = ws.OLEObjects("TempCombo") 
    On Error Resume Next 
    With cboTemp 
        .ListFillRange = "" 
        .LinkedCell = "" 
        .Visible = False 
    End With 
    On Error Goto errHandler 
    If Target.Validation.Type = 3 Then 
        Application.EnableEvents = False 
        str = Target.Validation.Formula1 
        str = Right(str, Len(str) - 1) 
        With cboTemp 
            .Visible = True 
            .Left = Target.Left 
            .Top = Target.Top 
            .Width = Target.Width + 15 
            .Height = Target.Height + 5 
            .ListFillRange = str 
            .LinkedCell = Target.Address 
        End With 
        cboTemp.Activate 
    End If 
     
errHandler: 
    Application.EnableEvents = True 
    Exit Sub 
     
End Sub 
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    Dim str As String 
    Dim cboTemp As OLEObject 
    Dim ws As Worksheet 
    Set ws = ActiveSheet 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 
     
    If Application.CutCopyMode Then 
         'allows copying and pasting on the worksheet
        Goto errHandler 
    End If 
     
    Set cboTemp = ws.OLEObjects("TempCombo") 
    On Error Resume Next 
    With cboTemp 
        .Top = 10 
        .Left = 10 
        .Width = 0 
        .ListFillRange = "" 
        .LinkedCell = "" 
        .Visible = False 
        .Value = "" 
    End With 
     
errHandler: 
    Application.ScreenUpdating = True 
    Application.EnableEvents = True 
    Exit Sub 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

I have seen your suggestion to go the non-macro autocomplete method. My concern is that I will be duplicating a lot of data. My validation list is 600+ long and will be growing. I don't know if I can skip selecting the validation data rows when creating pivot tables from the spreadsheet. I also noticed with this method, if my validation data has similar entries (i.e. Jordan Smith and Jordan Test), I have to type almost the whole last name before the name shows up. I can't type J and get the first name with J to show and click the drowdown arrow to see other J names. I think this method works great for more unique validation lists.

Thanks for your help.

Dear forum members,

We are writing a VBA code to calculate the correlation between stocks. The data is imported by Bloomberg. Part of the information is manually filled (thats where the formules are for) in another worksheet.

We do not have much knowledge about VBA but we are pretty happy with the code we have so far. We are still debugging but the code runs quite oke now.

The only problem we have is the speed: the code runs to slow!

We have included the code (it's a pretty long one) and hope some users will take a look at it. We don't expect you to rewrite the whole code (if you want to, please feel free to do so) but if you could 'scan' the code quickly and give us some points of improvement to speed up the process.


	VB:
	
 BLP_DATA_CTRLLib.BlpData 
 
Private Sub CommandButton1_Click() 
     
    Set objDataControl = New BlpData 
    Call objDataControl.Flush 
     
     'Script weergave uit (niet zichtbaar voor gebruiker)
    Application.ScreenUpdating = False 
     
     'Start timer
    sngStart = Timer 
     
     'Legen van cellen in Excel
    Dim rng As Range 
    Set rng = Range("D18:R1000") 
    Range(rng, rng).ClearContents 
     
     'Opzetten van velden voor array
    arrayFields = Array("PX_LAST") 
     
     ' Tickers tellen
    nr_comp = Range(Range("B18"), Range("B18").End(xlDown)).Rows.Count 
     
     'Bepaald grote van array
    Dim arraySecurities() As String 
    Redim arraySecurities(nr_comp) 
     
     'Leading Fund
    arraySecurities(0) = Range("B10").Value 
     ' Range("D18").FormulaR1C1 = "=R[-8]C[-2]"
     
     'Peers (per peer wordt data binnen gehaald)
    With Range("B18") 
        i = 1 
        Do While i

I've written the following macro to copy data from performance monitor logs and find some statistics from each day. The logs comma delimited files and are named SERVERPerfMon_mmddhh.csv where mm is the month, dd is the day, and hh is the hour. If I step through the code, it works, but if I just run it, none of the code after it is done copying seems to execute. The last section of data that it pastes is still highlighted. Any help would be appreciated.

I know the code could be cleaned up quite a bit, but I'd like to get it completely working before I revise it. It started out as two macros - one to copy and one to summarize the data, but when I combined them, it wouldn't work. I've tried using the call and application.run commands to run the second run from the first one, created a third macro to use the call/run commands to execute both of them, and even tried adding an application.wait between them, but I can't get them to run with one click. Anyway, here's the code and thanks in advance:


	VB:
	
 
Function FileThere(FileName As String) As Boolean 
    FileThere = (Dir(FileName) > "") 
End Function 
 
Sub Copy() 
     
     ' Turns off screen updating so that the macro will run faster
    Application.ScreenUpdating = False 
     
     ' Defines variables
    Dim LogFileStart As Integer 
    Dim StartDay As Integer 
    Dim StartMonth As Integer 
    Dim StartYear As Integer 
    Dim EndYear As Integer 
    Dim EndMonth As Integer 
    Dim EndDay As Integer 
    Dim LogFileEnd As Integer 
    Dim Counter1 As Integer 
    Dim Counter2 As Integer 
    Dim WorkbookName As String 
    Dim Day As Date 
    Dim DayEnd As Long 
    Dim DayStart As Long 
    Dim Counter As Long 
    Dim FirstDay As Date 
    Dim LastDay As Date 
     
     ' Stores the workbook name - used when switching between log file and workbook
    WorkbookName = ActiveWorkbook.Name 
     
     ' Adds a new sheet
    Sheets.Add 
     
     ' Prompts users for dates to look for log files (This is broken up because the first
    part only uses the month And day 
     ' while the second uses month, day, and year
    StartMonth = InputBox("Start: What month?") 
    StartDay = InputBox("Start: What day?") 
    StartYear = InputBox("Start: What year?") 
    EndMonth = InputBox("End: What month?") 
    EndDay = InputBox("End: What day?") 
    EndYear = InputBox("End: What year?") 
     
     ' Concatenates the variables for use in searching for the filename
    LogFileStart = StartMonth & StartDay 
    LogFileEnd = EndMonth & EndDay 
     
     ' Counter2 is used for the month and day of the log file
    Counter2 = LogFileStart 
     
     ' Starts a loop to look for log files with file names containing the numbers given
    In the Input boxes 
    For Counter2 = LogFileStart To LogFileEnd 
         
         ' This loop accounts for the fact that the log files start at different hours in the
        day And are named accordingly 
         ' Counter1 is used for the hour of the log file
        For Counter1 = 1 To 24 
             
             ' This if statement is used because Excel drops the 0 for dates from Jan to Sep, so
            the first condition adds it back, And the second Is For Oct To Dec ' without the 0
            If Counter2 < 999 Then 
                 
                 ' This if statement uses the FileThere function to find all log files that exist for
                the day 
                If FileThere("serverperflogsSERVERPerfMon_0" & Counter2 & 
                Counter1 & ".csv") Then 
                     
                     ' If it exists, this opens the file
                    Workbooks.Open FileName:="serverperflogsSERVERPerfMon_0" & 
                    Counter2 & Counter1 & ".csv" 
                     
                     ' Then selects and copies the data desired (5761 is the maximum number of times per
                    log file the statistics are recorded) 
                    Range("A2:H5762").Copy 
                     
                     ' This activates the macro's workbook
                    Windows(WorkbookName).Activate 
                    Range("A2").Select 
                     
                     ' This loop finds the next blank row in which to paste the data
                    Do Until ActiveCell = "" 
                        ActiveCell.Offset(1, 0).Select 
                    Loop 
                    ActiveSheet.Paste 
                     
                     ' This switches back to the log file and closes it, turning alerts off so that it
                    runs without the message about the clipboard 
                    Windows("SERVERPerfMon_0" & Counter2 & Counter1 & ".csv").Activate 
                    Application.DisplayAlerts = False 
                    ActiveWindow.Close 
                     
                     ' This turns alerts back on
                    Application.DisplayAlerts = True 
                    Windows(WorkbookName).Activate 
                    Range("A1").Select 
                     
                End If 
            Else 
                 
                 ' This is the same code except it doesn't have the 0 in the file name and is used
                For Oct-Dec 
                    If FileThere("serverperflogsSERVERPerfMon_" & Counter2 & 
                    Counter1 & ".csv") Then 
                        Workbooks.Open FileName:="serverperflogsSERVERPerfMon_" & 
                        Counter2 & Counter1 & ".csv" 
                        Range("A2:H5762").Copy 
                        Windows(WorkbookName).Activate 
                        Range("A2").Select 
                        Do Until ActiveCell = "" 
                            ActiveCell.Offset(1, 0).Select 
                        Loop 
                        ActiveSheet.Paste 
                        Windows("SERVERPerfMon_" & Counter2 & Counter1 & ".csv").Activate 
                        Application.DisplayAlerts = False 
                        ActiveWindow.Close 
                        Application.DisplayAlerts = True 
                        Range("A1").Select 
                         
                    End If 
                End If 
            Next 
            Range("A1").Select 
        Next 
         
         
         
         ' Adds the header rows and formats them
        Range("K1").Select 
        ActiveCell.FormulaR1C1 = "Available Ram(MB)" 
        Range("M1").Select 
        ActiveCell.FormulaR1C1 = "% Pagefile Usage" 
        Range("O1").Select 
        ActiveCell.FormulaR1C1 = "Hard Drive Avg" 
        Range("Q1").Select 
        ActiveCell.FormulaR1C1 = "Interrupts/Sec" 
        Range("S1").Select 
        ActiveCell.FormulaR1C1 = "% Processor" 
        Range("T1").Select 
        ActiveCell.FormulaR1C1 = "System Calls/Sec" 
        Range("J2").Select 
        ActiveCell.FormulaR1C1 = "Date" 
        Range("K2").Select 
        ActiveCell.FormulaR1C1 = "Min" 
        Range("L2").Select 
        ActiveCell.FormulaR1C1 = "Max" 
        Range("M2").Select 
        ActiveCell.FormulaR1C1 = "Min" 
        Range("N2").Select 
        ActiveCell.FormulaR1C1 = "Max" 
        Range("O2").Select 
        ActiveCell.FormulaR1C1 = "Read/Sec" 
        Range("P2").Select 
        ActiveCell.FormulaR1C1 = "Writes/Sec" 
        Range("Q2").Select 
        ActiveCell.FormulaR1C1 = "Min" 
        Range("R2").Select 
        ActiveCell.FormulaR1C1 = "Max" 
        Range("S2").Select 
        ActiveCell.FormulaR1C1 = "Avg" 
        Range("T2").Select 
        ActiveCell.FormulaR1C1 = "Min" 
        Range("U2").Select 
        ActiveCell.FormulaR1C1 = "Max" 
        Range("K1:L1").Select 
        With Selection 
            .MergeCells = True 
        End With 
        Range("M1:N1").Select 
        With Selection 
            .MergeCells = True 
        End With 
        Range("O1:P1").Select 
        With Selection 
            .MergeCells = True 
        End With 
        Range("Q1:R1").Select 
        With Selection 
            .MergeCells = True 
        End With 
        Range("T1:U1").Select 
        With Selection 
            .MergeCells = True 
        End With 
        Range("J1:U2").Select 
        Range("U2").Activate 
        With Selection 
            .HorizontalAlignment = xlCenter 
        End With 
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone 
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone 
        With Selection.Borders(xlEdgeLeft) 
            .LineStyle = xlContinuous 
            .Weight = xlThin 
            .ColorIndex = xlAutomatic 
        End With 
        With Selection.Borders(xlEdgeTop) 
            .LineStyle = xlContinuous 
            .Weight = xlThin 
            .ColorIndex = xlAutomatic 
        End With 
        With Selection.Borders(xlEdgeBottom) 
            .LineStyle = xlContinuous 
            .Weight = xlThin 
            .ColorIndex = xlAutomatic 
        End With 
        With Selection.Borders(xlEdgeRight) 
            .LineStyle = xlContinuous 
            .Weight = xlThin 
            .ColorIndex = xlAutomatic 
        End With 
        With Selection.Borders(xlInsideVertical) 
            .LineStyle = xlContinuous 
            .Weight = xlThin 
            .ColorIndex = xlAutomatic 
        End With 
        With Selection.Borders(xlInsideHorizontal) 
            .LineStyle = xlContinuous 
            .Weight = xlThin 
            .ColorIndex = xlAutomatic 
        End With 
         
         ' Concatenates the variables for use in searching for the beginning and end of log data
        FirstDay = StartMonth & "/" & StartDay & "/" & StartYear 
        LastDay = EndMonth & "/" & EndDay & "/" & EndYear 
         
        Day = FirstDay 
         
         ' This loop runs for each day in the range
        For Day = FirstDay To LastDay 
            Range("A2").Select 
            DayStart = 2 
             
             ' The first part of the if statement determines whether the first row in the data is
            from a previous day 
            If ActiveCell < Day Then 
                 
                 ' This loop moves down the rows in the data until it contains data from the day it
                needs 
                Do Until ActiveCell >= Day 
                     
                     ' This fills the DayStart variable with the row number of the beginning of the data
                    DayStart = DayStart + 1 
                    ActiveCell.Offset(1, 0).Select 
                     
                     ' This exits the do loop if it reaches the end of the data
                    If ActiveCell = "" Then Exit Do 
                Loop 
                 
                DayEnd = DayStart - 1 
                 
                 ' This loop looks for when the data from the day ends
                 ' The DayEnd variable will be the row number of the last of the data
                Do Until ActiveCell >= Day + 1 
                    DayEnd = DayEnd + 1 
                    ActiveCell.Offset(1, 0).Select 
                    If ActiveCell = "" Then Exit Do 
                Loop 
            Else 
                 
                 ' This does the same thing if the data starts on the day needed
                DayEnd = 2 
                Do Until ActiveCell >= Day + 1 
                    DayEnd = DayEnd + 1 
                    ActiveCell.Offset(1, 0).Select 
                    If ActiveCell = "" Then Exit Do 
                Loop 
            End If 
             
             ' This finds the next blank line in the summary section to paste the summary
            information 
            Range("J2").Select 
            Counter = 2 
            Do Until ActiveCell = "" 
                Counter = Counter + 1 
                ActiveCell.Offset(1, 0).Select 
            Loop 
             
             
             ' This pastes the summary information into one row for each day
            ActiveCell.FormulaR1C1 = Day 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=MIN(R[" & DayStart - Counter & "]C[-9]:R[" & 
            DayEnd - Counter & "]C[-9])" 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=MAX(R[" & DayStart - Counter & "]C[-10]:R[" & 
            DayEnd - Counter & "]C[-10])" 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=MIN(R[" & DayStart - Counter & "]C[-10]:R[" & 
            DayEnd - Counter & "]C[-10])" 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=MAX(R[" & DayStart - Counter & "]C[-11]:R[" & 
            DayEnd - Counter & "]C[-11])" 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=AVERAGE(R[" & DayStart - Counter & "]C[-11]:R[" & 
            DayEnd - Counter & "]C[-11])" 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=AVERAGE(R[" & DayStart - Counter & "]C[-11]:R[" & 
            DayEnd - Counter & "]C[-11])" 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=MIN(R[" & DayStart - Counter & "]C[-11]:R[" & 
            DayEnd - Counter & "]C[-11])" 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=MAX(R[" & DayStart - Counter & "]C[-12]:R[" & 
            DayEnd - Counter & "]C[-12])" 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=AVERAGE(R[" & DayStart - Counter & "]C[-12]:R[" & 
            DayEnd - Counter & "]C[-12])" 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=MIN(R[" & DayStart - Counter & "]C[-12]:R[" & 
            DayEnd - Counter & "]C[-12])" 
            ActiveCell.Offset(0, 1).Select 
            ActiveCell.FormulaR1C1 = "=MAX(R[" & DayStart - Counter & "]C[-13]:R[" & 
            DayEnd - Counter & "]C[-13])" 
             
        Next 
         
         ' Turns screen updating back on
        Application.ScreenUpdating = True 
         
    End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I want to automatically copy data onto a worksheet. The ranges of source data is always dynamic. What I would like to do is find the first un-populated row, and select that cell for data input. Here is what I have so far:

I declare this as a global variable:
strFirstEmptyCell as String


	VB:
	
 String) 
    ' Macro created by 
    ' Creation Date: 04-05-2003 
    ' Version 1.0 
    ' 
    ' Function: Will select the range of populated data, based on a known number of 
    '           populated columns. 
     
    Dim LastCell As Range 
     
    With ThisWorkbook.Worksheets(strSheet) 
        'modify the content of " " To select which column Is used To find last empty cell 
        Set LastCell = .Cells(.Rows.Count, strName).End(xlUp) 
        If IsEmpty(LastCell) Then 
            'do Nothing 
        Else 
            'modify content of (row, column) offset To decide which box Is selected 
            Set LastCell = LastCell.Offset(0, -1) 
        End If 
    End With 
    rngFirstEmptyCell = LastCell.Address 
    Set LastCell = Nothing 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
The problem is that when I pass the strFirstEmptyCell to a paste command, I receive a run-time error '13' Type Mismatch.

Here is the paste command i use:

	VB:
	
ThisWorkbook.Worksheets(varDataSheet(i)).Cells(rngFirstEmptyCell).PasteSpecial Paste:=xlValues 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Any ideas out there folks, or any better ways of selecting the first cell on the first unpopulated row??

Regards,
Damian.

Hi,

I've been working on a code for AGES now and am nearly finished but can't seem to get this last piece to work correctly. The macro is supposed to open a userform, let me pick which worksheet to draw data from and which specific columns from that sheet to copy into a continuous array (the listbox contains the headers/titles for each column, but not the columns themselves - they're too big). So I basically want to pick any combination of headers/columns from the listbox and have a new array created containing ONLY those selected columns; for example, if I pick cols A-G, I want the array to contain 7 columns, but if I only pick A, C, E, & G, the array should only contain the data from 4 columns: ACEG).The macro gets a lot more complicated from there, but that's the bit that I'm having trouble with.

You see, the code works perfectly if I select ALL of the columns but not if I skip ones along the way. When I do that, the macro usually ignores the contents of the unselected columns but still transfers their SPACE into the array (resulting in a blank column) instead of just skipping over the unselected ones entirely. Oddly enough, if more than one column in a row is skipped, the resulting array still leaves one blank column (not one per unselected header). Even weirder.. the macro will often skip some of the unselected columns (like it's supposed to) while, at the same time, leaving blanks for others. I can't see any rhyme nor reason to its pattern. And finally, unless all the headers/columns are selected from the listbox, the macro also consistently leaves a blank column for the last selected header.

Can anyone else see where I've made a mistake or why this code isn't working consistently? I'll attach a copy of the entire file in case you're interested in seeing how it all fits together but, if not, I think the following code should be enough to diagnose what's wrong:

	VB:
	
 
Option Base 1 
 
Private Sub ListBox2_Click() 
    Dim UserSheet, WSh As Variant, rngLastCol As Integer 
    UserSheet = ListBox2.Text ' Get name of user-selected worksheet
    ListBox1.Clear 
    For Each WSh In ThisWorkbook.Worksheets(UserSheet).Range("A1", Range("A1").End(xlToRight) & "1") _      
		UserForm1.ListBox1.AddItem WSh.Value 
    Next WSh 
    ListBox1.MultiSelect = fmMultiSelectExtended 
    ListBox1.Enabled = True 
    ListBox1.SetFocus 
End Sub 
 
 
Public Sub CmdBttnRun_Click() 
    Dim WB As Workbook 
    Dim userCols As Integer, a(256) As Integer, i As Integer, j As Integer, k As Integer, x As Long 
    Dim newCol As Integer, skipCount As Integer, UserSheet, TotalRows As Integer 
    Dim TempDataArr() As Variant, HdrDataArr() As Variant 
‘ 
    UserForm1.Hide 
    UserSheet = ListBox2.Text 
    TotalRows = ThisWorkbook.Worksheets(UserSheet).UsedRange.Rows.Count 
    userCols = 0 
    For i = 0 To ListBox1.ListCount - 1 
        If ListBox1.Selected(i) = True Then 
            userCols = i + 1 
            a(i + 1) = userCols 
        End If 
    Next i 
‘ 
    k = 1 
    colCount = 1 
    Do Until k = ListBox1.ListCount 
        If a(k)  0 Then 
            colCount = colCount + 1 
        End If 
        k = k + 1 
    Loop 
‘ 
    Redim TempDataArr(TotalRows, colCount + 1) As Variant  ‘contains the selected columns 
    Redim HdrDataArr(1, colCount + 1) As Variant ‘contains the headers For the selected columns 
    j = 1 
    newCol = 0 
    skipCount = 0 
    Do Until j = ListBox1.ListCount 
        If a(j)  0 Then 
            newCol = newCol + 1 
            For x = 1 To TotalRows - 1 
                TempDataArr(x, newCol + 1) = WB.Worksheets(UserSheet).Cells(x + 1, a(j)).Value 
                If x = 1 Then 
                    HdrDataArr(x, newCol + 1) = WB.Worksheets(UserSheet).Cells(x, a(j)).Value 
                End If 
            Next x 
            j = j + 1 
        Else 
            skipCount = skipCount + 1 
            newCol = j - (skipCount - 1) 
            j = j + 1 
        End If 
    Loop 
    ‘ rest of macro… 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
So can anyone see something that I can't?? I'd even just appreciate a suggestion about where the problem might lie...
Thanks for any help or info you can give, Fern

I often have to move columns of data from multiple tabs on to one master sheet, and wondered if anyone had a macro that would go through all of these and do it for me?

I have a macro that will take the data from multiple tabs and paste it all on to one 'Combined' tab, pasting each tab's data underneath the last lot, which is great if the worksheets are identically structured.

I need something exactly like this but for columns instead of rows... I've had a go at amending this one myself, but have very limited experience with VBA.

Code:
Sub Combine()
    Dim J As Integer
'Source: http://exceltips.vitalnews.com/Pages..._Into_One.html
    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add ' add a sheet in first place
    Sheets(1).Name = "Combined"
    ' copy headings
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    ' work through sheets
    For J = 2 To Sheets.Count ' from sheet 2 to last sheet
        Sheets(J).Activate ' make the sheet active
        Range("A1").Select
        Selection.CurrentRegion.Select ' select all cells in this sheets
        ' select all lines except title
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        ' copy cells selected in the new sheet on last line
        Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
    Next
End Sub
Thanks in advance for any help!

Today's hangup relates to sorting under macro control.

I have a worksheet with a data base type list (16 cols, 10000 rows deep) which contains only 30 records, for testing purposes. Each cell is bordered in all 4 sides.
There will be a bunch or reports associated with this, requiring filtering and/or sorting. The macro instructions I applied so far are:

1) Locate last row.
2) Select the range from first to last row and apply a common row height (say, 24).
3) Sort as required
4) Filter as required.
5) Print

The sorting step has invariably failed.
The funny thing is that the code I used is the one produced by recording the steps. I am able to sort that segment manually, but the macro instructions fail.

Any suggestions? here is the code...

Selection.Sort Key1:=Range("F5"), Order1:=xlAscending, Key2:=Range("H5") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal

Hello,
I have a macro that creates a few named ranges for me, I would like to edit this macro so that it would only add the the row to the range if there was a Y in column BI (or 61), Any help would be apprecieated.

Here is my currient macro:
Code:
Sub CycleTimeRanges()
'find last data row:
    Application.Goto Reference:="R65536C1"
    Selection.End(xlUp).Select
    lastrow = ActiveCell.Row
'Create named ranges
ActiveWorkbook.Names.Add Name:="St_to_DR", _
    RefersTo:=Range(Cells(1, 55), Cells(lastrow, 55)), Visible:=True
ActiveWorkbook.Names.Add Name:="DR_to_FFMet", _
    RefersTo:=Range(Cells(1, 56), Cells(lastrow, 56)), Visible:=True
ActiveWorkbook.Names.Add Name:="FFMet_to_NPInsp", _
    RefersTo:=Range(Cells(1, 58), Cells(lastrow, 58)), Visible:=True
ActiveWorkbook.Names.Add Name:="NPInsp_to_Del", _
    RefersTo:=Range(Cells(1, 59), Cells(lastrow, 59)), Visible:=True
ActiveWorkbook.Names.Add Name:="St_to_Del", _
    RefersTo:=Range(Cells(1, 60), Cells(lastrow, 60)), Visible:=True
ActiveWorkbook.Names.Add Name:="StartDates", _
    RefersTo:=Range(Cells(1, 4), Cells(lastrow, 4)), Visible:=True
End Sub


Hello all,

I have a module that runs perfectly when I go through tools-> macro-> macros-> Module1-> Run. I want to automate the process and run by clicking a command button. When I put the code in...

Private Sub CmdButtonZZ_Process_Click()

I get an "Expected End Sub" error. What do I need to change in the code that is posted below or do I need to go about this in a different manner? Any assistance is greatly appreciated. Thanks in advance.

Private Sub CmdButtonZZ_Process_Click()
Sub CopyFromWorksheets()
Application.Calculation = xlCalculationManual
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'ZZ-Process Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets

Set wrk = ActiveWorkbook 'Working in active workbook

For Each sht In wrk.Worksheets
If sht.Name = "ZZ-Process" Then
MsgBox "There is a worksheet called as 'ZZ-Process'." & vbCrLf & _
"Please remove or rename this worksheet since 'ZZ-Process' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "ZZ-Process"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(2)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 2).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Sheets(Array("Standard", "Full", "Half", "Ineligible", "BilStd", "Bilhalf", "BilFull", "BilIE"))
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 2), sht.Cells(65536, 4).End(xlUp).Resize(, colCount))
'Put data into the ZZ-Process worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht

'Fit the columns in ZZ-Process worksheet
trg.Columns.AutoFit

'Screen updating should be activated
Application.ScreenUpdating = True
Sheets("ZZ-Process").Select
Sheets("ZZ-Process").Move
End Sub

Good morning, I have a large macro (actually 4 macros) which opens a number of text and csv files, grabs information from the files and puts into a master file then renames the csv files and file into a new folder.

The macro works great, with one exception. As part of the new file name, I want to grab a value (job number) designated as MyNum from the csv file (cell B1) and add it to the save as name. This works for the two text files I work with in step one and two, but not the batch of csv files I work with in Step 3 (Function OpenCSV). For these files, it just skips the MyNum portion of the code. I wonder if Excel thinks the job number is really a date (ex. 38958) and the number isn't taking because it would be trying to add a date (ex. 8/29/2006) to the file name, which wouldn't work because of the "/"...

Any ideas how to make this work?

Complete code-
Code:
Sub Anne_Daily_Step1_ImportNightlyFiles()
Application.ScreenUpdating = False
'sets date standard
MyDate = Format(Now, "mm.dd.yy")
MyMonth = Format(Now, "mmmm")
MyYear = Format(Now, "yyyy")
'sets CSV Path
MyCSVPath = "P:CBF MASTER FILESCBF Operating FolderWorkFlowOneUpdated Billing" & MyYear & "" & MyMonth & "Daily CSV Files"
'sets master WFO file path and name
MyMasterPath = "P:CBF MASTER FILESCBF Operating FolderWorkFlowOneUpdated Billing" & MyYear & ""
MyMaster = "WFO Daily Postage Log" & MyYear & ".update.xls"
Dim Valleyfile As Workbook
Dim CurBook As Worksheet
Set CurBook = Workbooks("WFO Daily Postage Log" & MyYear & ".update.xls").Sheets(MyMonth & " " & MyYear)
On Error GoTo NextStep
With Application.FileSearch
        .NewSearch
        .LookIn = MyCSVPath
        .FileType = msoFileTypeAllFiles
        .Filename = "*baycity_rpt.txt"
        .Execute
 
         Set txtfile = Workbooks.Open(.FoundFiles(1))
    End With
 
lastRow = Cells(Rows.Count, "A").End(xlUp).Row - 3
Range("A:A").Select
    Selection.Replace What:="Total                        ", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="Total                       ", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="Total                      ", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
 
Range("E" & lastRow).Value = "Finish"
With Application.FileSearch
        .NewSearch
        .LookIn = MyCSVPath
        .FileType = msoFileTypeAllFiles
        .Filename = "saginaw_baycity.csv"
        .Execute
 
         Set Valleyfile = Workbooks.Open(.FoundFiles(1))
    End With
lastRowWFO = CurBook.Cells(Rows.Count, "A").End(xlUp).Row + 1
txtfile.ActiveSheet.Name = "Sheet1"
Valleyfile.ActiveSheet.Name = "Sheet1"
'------------------------------------------
'COPY DATA FROM SRC TO MASTER
'------------------------------------------
With CurBook.Rows(lastRowWFO)
    .Cells(, 1).Value = txtfile.Worksheets("Sheet1").Cells(2, 1)
    .Cells(, 2).Value = "14900 - The Bay City Times"
    .Cells(, 3).Value = Valleyfile.Worksheets("Sheet1").Cells(2, 1)
    .Cells(, 4).Value = txtfile.Worksheets("Sheet1").Cells(lastRow, 1)
    .Cells(, 5).Value = txtfile.Worksheets("Sheet1").Cells(lastRow, 5)
    .Cells(, 7).Formula = "=RC[-2]+RC[-1]"
End With
'------------------------------------------
'DISABLE ALERTS
'------------------------------------------
Application.DisplayAlerts = False
'------------------------------------------
'CLOSE SOURCE FILE & SAVE
'------------------------------------------
MyNum = Valleyfile.Worksheets("Sheet1").Cells(2, 1).Value
txtfile.SaveAs Filename:="P:CBF MASTER FILESCBF Operating FolderWorkFlowOneUpdated Billing" & MyYear & "" & MyMonth & "Daily
CSV FilesCompleted Postage ReportsBay Citybaycity " & MyNum & " " & MyDate & ".xls"
Kill MyCSVPath & "*baycity_rpt.txt"
txtfile.Close
Valleyfile.Close
Application.DisplayAlerts = True
NextStep:
Call Anne_IgnoreMe1
Application.ScreenUpdating = True
End Sub
Sub Anne_IgnoreMe1()
Application.ScreenUpdating = False
'sets date standard
MyDate = Format(Now, "mm.dd.yy")
MyMonth = Format(Now, "mmmm")
MyYear = Format(Now, "yyyy")
'sets CSV Path
MyCSVPath = "P:CBF MASTER FILESCBF Operating FolderWorkFlowOneUpdated Billing" & MyYear & "" & MyMonth & "Daily CSV Files"
'sets master WFO file path and name
MyMasterPath = "P:CBF MASTER FILESCBF Operating FolderWorkFlowOneUpdated Billing" & MyYear & ""
MyMaster = "WFO Daily Postage Log" & MyYear & ".update.xls"
Dim Valleyfile As Workbook
Dim CurBook As Worksheet
Set CurBook = Workbooks("WFO Daily Postage Log" & MyYear & ".update.xls").Sheets(MyMonth & " " & MyYear)
On Error GoTo NextStep2
With Application.FileSearch
        .NewSearch
        .LookIn = MyCSVPath
        .FileType = msoFileTypeAllFiles
        .Filename = "*saginaw_rpt.txt"
        .Execute
 
         Set txtfile = Workbooks.Open(.FoundFiles(1))
    End With
 
lastRow = Cells(Rows.Count, "A").End(xlUp).Row - 3
Range("A:A").Select
    Selection.Replace What:="Total                        ", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="Total                       ", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
    Selection.Replace What:="Total                      ", Replacement:="", _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
        False, ReplaceFormat:=False
 
Range("E" & lastRow).Value = "Finish"
With Application.FileSearch
        .NewSearch
        .LookIn = MyCSVPath
        .FileType = msoFileTypeAllFiles
        .Filename = "saginaw_baycity.csv"
        .Execute
 
         Set Valleyfile = Workbooks.Open(.FoundFiles(1))
    End With
lastRowWFO = CurBook.Cells(Rows.Count, "A").End(xlUp).Row + 1
txtfile.ActiveSheet.Name = "Sheet1"
Valleyfile.ActiveSheet.Name = "Sheet1"
'------------------------------------------
'COPY DATA FROM SRC TO MASTER
'------------------------------------------
With CurBook.Rows(lastRowWFO)
    .Cells(, 1).Value = txtfile.Worksheets("Sheet1").Cells(2, 1)
    .Cells(, 2).Value = "14700 - The Saginaw News"
    .Cells(, 3).Value = Valleyfile.Worksheets("Sheet1").Cells(2, 1)
    .Cells(, 4).Value = txtfile.Worksheets("Sheet1").Cells(lastRow, 1)
    .Cells(, 5).Value = txtfile.Worksheets("Sheet1").Cells(lastRow, 5)
    .Cells(, 7).Formula = "=RC[-2]+RC[-1]"
End With
'------------------------------------------
'DISABLE ALERTS
'------------------------------------------
Application.DisplayAlerts = False
'------------------------------------------
'CLOSE SOURCE FILE & SAVE
'------------------------------------------
MyNum = Valleyfile.Worksheets("Sheet1").Cells(2, 1).Value
txtfile.SaveAs Filename:="P:CBF MASTER FILESCBF Operating FolderWorkFlowOneUpdated Billing" & MyYear & "" & MyMonth & "Daily
CSV FilesCompleted Postage ReportsSaginawsaginaw " & MyNum & " " & MyDate & ".xls"
Kill MyCSVPath & "*saginaw_rpt.txt"
txtfile.Close
Valleyfile.Close
Application.DisplayAlerts = True
NextStep2:
Call Anne_IgnoreMe2
Application.ScreenUpdating = True
End Sub
Sub Anne_IgnoreMe3()
'------------------------------------------
'DEFINE VARIABLES
'------------------------------------------
Dim MyDate As String, MyMonth As String, MyYear As String, MyCSVPath As String
Dim MyMasterPath As String, MyMaster As String
Dim CurBook As Worksheet
Dim CSVListItem As Range
'------------------------------------------
'DISABLE SCREEN REFRESH
'------------------------------------------
Application.ScreenUpdating = False
'------------------------------------------
'ASSIGN KEY VARIABLES
'------------------------------------------
MyDate = Format(Now, "mm.dd.yy")
MyMonth = Format(Now, "mmmm")
MyYear = Format(Now, "yyyy")
MyCSVPath = "P:CBF MASTER FILESCBF Operating FolderWorkFlowOneUpdated Billing" & MyYear & "" & MyMonth & "Daily CSV Files"
MyMasterPath = "P:CBF MASTER FILESCBF Operating FolderWorkFlowOneUpdated Billing" & MyYear & ""
MyMaster = "WFO Daily Postage Log" & MyYear & ".update.xls"
Set CurBook = Workbooks("WFO Daily Postage Log" & MyYear & ".update.xls").Sheets(MyMonth & " " & MyYear)
'------------------------------------------
'LOOP FILE LIST AND INVOKE OPENCSV(...)
'------------------------------------------
For Each CSVListItem In ThisWorkbook.Sheets("CSVList").Range("A1:A22")
    If Not OpenCsv(MyCSVPath, CStr(CSVListItem), CurBook, CSVListItem.Offset(, 1), _
        MyCSVPath & "Completed Postage Reports" & CSVListItem.Offset(, 3) & CSVListItem.Offset(, 2) & " " & MyNum & " " &
MyDate & ".csv") Then
'            MsgBox "Failed..."
    End If
Next
'------------------------------------------
'END
'------------------------------------------
Call Anne_IgnoreMe4
End Sub
 
Function OpenCsv(MyCSVPath As String, CSVFileName As String, CurBook As Worksheet, _
    BValue As String, SaveAsPath As String) As Boolean
'------------------------------------------
'DEFINE VARIABLES
'------------------------------------------
Dim SrceBook As Workbook
Dim lastRow As Long, lastRowWFO As Long
'------------------------------------------
'SET SPECIFIC HANDLER
'------------------------------------------
On Error GoTo Err_OpenCsv
'------------------------------------------
'OPEN PARSED FILE
'------------------------------------------
With Application.FileSearch
    .NewSearch
    .LookIn = MyCSVPath
    .FileType = msoFileTypeAllFiles
    .Filename = CSVFileName
    .Execute
     Set SrceBook = Workbooks.Open(.FoundFiles(1))
End With
'------------------------------------------
'RESET HANDLER
'------------------------------------------
On Error GoTo 0
'------------------------------------------
'SET PASTE ROW + LAST ROW IN SOURCE FILE
'------------------------------------------
lastRowWFO = CurBook.Cells(Rows.Count, "A").End(xlUp).Row + 1
SrceBook.ActiveSheet.Name = "Sheet1"
lastRow = SrceBook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
'------------------------------------------
'COPY DATA FROM SRC TO MASTER
'------------------------------------------
With CurBook.Rows(lastRowWFO)
    .Cells(, 1).Value = SrceBook.Worksheets("Sheet1").Cells(3, 1)
    .Cells(, 2).Value = BValue
    .Cells(, 3).Value = SrceBook.Worksheets("Sheet1").Cells(2, 1)
    .Cells(, 4).Value = SrceBook.Worksheets("Sheet1").Cells(lastRow, 2)
    .Cells(, 5).Value = SrceBook.Worksheets("Sheet1").Cells(lastRow, 5)
    .Cells(, 7).Formula = "=RC[-2]+RC[-1]"
End With
'------------------------------------------
'DISABLE ALERTS
'------------------------------------------
Application.DisplayAlerts = False
'------------------------------------------
'CLOSE SOURCE FILE & SAVE
'------------------------------------------
MyNum = SrceBook.Worksheets("Sheet1").Cells(2, 1).Value
SrceBook.SaveAs SaveAsPath
Kill MyCSVPath & CSVFileName
SrceBook.Close
'------------------------------------------
'ENABLE ALERTS
'------------------------------------------
Application.DisplayAlerts = True
'------------------------------------------
'RETURN BOOLEAN SUCCESS
'------------------------------------------
OpenCsv = True
'------------------------------------------
'END
'------------------------------------------
Exit Function
'------------------------------------------
'ERROR HANDLER FOR NON-EXISTENT FILE (to end)
'------------------------------------------
Err_OpenCsv:
End Function

Step 3 and Function
Code:
Sub Anne_IgnoreMe3()
'------------------------------------------
'DEFINE VARIABLES
'------------------------------------------
Dim MyDate As String, MyMonth As String, MyYear As String, MyCSVPath As String
Dim MyMasterPath As String, MyMaster As String
Dim CurBook As Worksheet
Dim CSVListItem As Range
'------------------------------------------
'DISABLE SCREEN REFRESH
'------------------------------------------
Application.ScreenUpdating = False
'------------------------------------------
'ASSIGN KEY VARIABLES
'------------------------------------------
MyDate = Format(Now, "mm.dd.yy")
MyMonth = Format(Now, "mmmm")
MyYear = Format(Now, "yyyy")
MyCSVPath = "P:CBF MASTER FILESCBF Operating FolderWorkFlowOneUpdated Billing" & MyYear & "" & MyMonth & "Daily CSV Files"
MyMasterPath = "P:CBF MASTER FILESCBF Operating FolderWorkFlowOneUpdated Billing" & MyYear & ""
MyMaster = "WFO Daily Postage Log" & MyYear & ".update.xls"
Set CurBook = Workbooks("WFO Daily Postage Log" & MyYear & ".update.xls").Sheets(MyMonth & " " & MyYear)
'------------------------------------------
'LOOP FILE LIST AND INVOKE OPENCSV(...)
'------------------------------------------
For Each CSVListItem In ThisWorkbook.Sheets("CSVList").Range("A1:A22")
    If Not OpenCsv(MyCSVPath, CStr(CSVListItem), CurBook, CSVListItem.Offset(, 1), _
        MyCSVPath & "Completed Postage Reports" & CSVListItem.Offset(, 3) & CSVListItem.Offset(, 2) & " " & MyNum & " " &
MyDate & ".csv") Then
'            MsgBox "Failed..."
    End If
Next
'------------------------------------------
'END
'------------------------------------------
Call Anne_IgnoreMe4
End Sub
 
Function OpenCsv(MyCSVPath As String, CSVFileName As String, CurBook As Worksheet, _
    BValue As String, SaveAsPath As String) As Boolean
'------------------------------------------
'DEFINE VARIABLES
'------------------------------------------
Dim SrceBook As Workbook
Dim lastRow As Long, lastRowWFO As Long
'------------------------------------------
'SET SPECIFIC HANDLER
'------------------------------------------
On Error GoTo Err_OpenCsv
'------------------------------------------
'OPEN PARSED FILE
'------------------------------------------
With Application.FileSearch
    .NewSearch
    .LookIn = MyCSVPath
    .FileType = msoFileTypeAllFiles
    .Filename = CSVFileName
    .Execute
     Set SrceBook = Workbooks.Open(.FoundFiles(1))
End With
'------------------------------------------
'RESET HANDLER
'------------------------------------------
On Error GoTo 0
'------------------------------------------
'SET PASTE ROW + LAST ROW IN SOURCE FILE
'------------------------------------------
lastRowWFO = CurBook.Cells(Rows.Count, "A").End(xlUp).Row + 1
SrceBook.ActiveSheet.Name = "Sheet1"
lastRow = SrceBook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
'------------------------------------------
'COPY DATA FROM SRC TO MASTER
'------------------------------------------
With CurBook.Rows(lastRowWFO)
    .Cells(, 1).Value = SrceBook.Worksheets("Sheet1").Cells(3, 1)
    .Cells(, 2).Value = BValue
    .Cells(, 3).Value = SrceBook.Worksheets("Sheet1").Cells(2, 1)
    .Cells(, 4).Value = SrceBook.Worksheets("Sheet1").Cells(lastRow, 2)
    .Cells(, 5).Value = SrceBook.Worksheets("Sheet1").Cells(lastRow, 5)
    .Cells(, 7).Formula = "=RC[-2]+RC[-1]"
End With
'------------------------------------------
'DISABLE ALERTS
'------------------------------------------
Application.DisplayAlerts = False
'------------------------------------------
'CLOSE SOURCE FILE & SAVE
'------------------------------------------
MyNum = SrceBook.Worksheets("Sheet1").Cells(2, 1).Value
SrceBook.SaveAs SaveAsPath
Kill MyCSVPath & CSVFileName
SrceBook.Close
'------------------------------------------
'ENABLE ALERTS
'------------------------------------------
Application.DisplayAlerts = True
'------------------------------------------
'RETURN BOOLEAN SUCCESS
'------------------------------------------
OpenCsv = True
'------------------------------------------
'END
'------------------------------------------
Exit Function
'------------------------------------------
'ERROR HANDLER FOR NON-EXISTENT FILE (to end)
'------------------------------------------
Err_OpenCsv:
End Function



No luck finding an answer? You could always try Google.