Free Microsoft Excel 2013
Quick Reference
Free Microsoft 2013 Quick Reference Guide

Free Microsoft Excel 2013 Quick Reference

Vba code for getting the line below selection end xlup select Results

I ave this code:

Sheets("Hx").Select
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select

The goal is to have the first blank row selected so I can copy some text there. The above does a good job selecting the last row with data, but I need the row below that (that is empty) what do I do to drop down a line, or paste to the line below where that code leaves me?

Thanks.

Hi there,

I'm new-ish to VBA (Excel 2003) so please bear with me on this. Thanks in advance for your help!

I've taken data from a fixed-length text file and the records are identified using the first two characters on each line of the text file. I've managed to identify these in each row with other bits of code so that was fine.

Now, I have 56 string variables (identifying my record types), which I'm assigning into an array. Then, I want to go through each variable in the array, performing the same action by way of a For Next Loop where, by taking this particular RecIDNo (see my code) string variable I will get the code to copy/paste the data into the relevant worksheet (where later on I will apply a text to columns using another array). But first, this set must work before I can do that!

To avoid confusion, please note that the record types i.e. 01 through to 56, will be filtered, then copied into the corresponding worksheet with the same number.

The problem I'm getting is the autofilter I'm applying, then the array I'm trying to reference (to avoid repetitive coding!) doesn't work as the code doesn't compile (I've not worked a lot with Arrays but I'm learning all the time!)

Here's my code


	VB:
	
 1 
Sub test() 
     
     'The array is declared here:
    Dim RecIDNo(56) As String 
     
     'The arrays are assigned the string variables below:
    RecIDNo(1) = "01" 
    .... 
    RecIDNo(56) = "56" 
     
     'This worksheet contains my data:
    Sheets("DATA").Select 
     
    For RecIDNo(1 To 56) '

Hi folks, need some help from you guys again!

I have 2 sections of code looking for a blank cell in various columns...
(Finds the bottom most occupied cell in another column and starting from the bottom most blank cell, changes the blank into showing some text)

The first section of code works fine and is fast, whereas the section section works but takes a good few seconds for each line (as my data can contain over 2000 lines this is no good)

Any help would be most appreciated.

The Code -

Code:
'    ' ********** Manipulate TASKS CLOSED to show FSC Dept Name from Blank *****************
' ******* THIS SECTION OF CODE WORKS FINE AND IS FAST! ***************
    Sheets("Tasks Closed").Select ' select the sheet we want to work on
   
   ' Check for bottom of column B
    Columns("b:b").ColumnWidth = 8
    Range("b65536").End(xlUp).Select
    ActiveCell.Offset(0, 2).Select
    
    ' continue checking until gets to row 2
    While ActiveCell.Row > 1
    
    ' Replace a blank space with FSC
    ActiveCell.Replace What:="", Replacement:="FSC", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=True, _
    ReplaceFormat:=False
    Application.FindFormat.Clear
    Selection.Replace What:="", Replacement:="FSC", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    
   ' move up a cell and check all over again
    ActiveCell.Offset(-1, 0).Select
    Wend
    
' ********** Manipulate TASKS CLOSED to show FSC Dept Number as "Supplier" from Blank *****************
' ******* THIS SECTION OF CODE WORKS BUT IS SO SLOW - WHY???? ***************

    Sheets("Tasks Closed").Select ' select the sheet we want to work on
   
   ' Check for bottom of column A
    Columns("a:a").ColumnWidth = 8
    Range("a65536").End(xlUp).Select
    ActiveCell.Offset(0, 2).Select
    
    ' continue checking until gets to row 2
    While ActiveCell.Row > 1
    
    ' Replace a blank space with Supplier
    ActiveCell.Replace What:="", Replacement:="Supplier"
    
' Various lines below changed to comments to see if it speeds up
    
    ', LookAt:=xlPart, _
    'SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=True, _
    'ReplaceFormat:=False
    'Application.FindFormat.Clear
    'Selection.Replace What:="", Replacement:="Supplier", LookAt:=xlPart, _
    'SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    'ReplaceFormat:=False
    
   ' move up a cell and check all over again
    ActiveCell.Offset(-1, 0).Select
    Wend


I am new with VBA - is the code below copying from Test1 and Test2 to paste into current spreadsheet??

Why am I getting an error on this line form the code below.

Workbooks.Open Filename:=ar(i)

It seems not to see the files I am trying to open????

_____________________________________________________

Sub macro2()
'

Dim present_workbook As String
Dim ar As Variant
ar = Array("D:Documents and SettingsMy Documentstest1.xls ", " D:Documents and SettingsMy Documentstest2.xls ") ' all the spread sheets
present_workbook = ActiveWorkbook.Name
For i = 0 To UBound(ar)
Workbooks.Open Filename:=ar(i)
temp = ActiveWorkbook.Name
Range("A1:G1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.End(xlDown).Select
If (ActiveCell.Row < 65536) Then
Range("A1:G1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks(present_workbook).Activate
Sheets("Sheet1").Select
Range("A65535").Select
Selection.End(xlUp).Select
If (ActiveCell.Row <> 1) Then
ActiveCell.Offset(1, 0).Select
End If
ActiveSheet.Paste
Application.CutCopyMode = False

End If
Workbooks(temp).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Next
End Sub

Hello Everyone,

Im a newbie to VBA, im unable to get an idea as to how would i paste the Found values from a cell

This is code

For x = 1 To FinalRow
        ' Decide if to copy based on column H
        Sheets("Sheet").Select
        ThisValue = Cells(x, 2).Value
        'MsgBox (ThisValue)
        DateValue = Cells(x, 3).Value
        'MsgBox (DateValue)
       MonthValue = Application.WorksheetFunction.Text(Cells(x, 4).Value, "MMM")
       MsgBox MonthValue
       
       
      If ThisValue = "High" Then
            Sheets("High").Select
            Range("B" & DateValue & ":BM" & DateValue).Select
            Selection.Copy
            
            With Sheets("data").Range("A1:L1")
            
            strsearch = Cells.Find(What:=MonthValue, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole,
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            lastline = Range("A65536").End(xlUp).Row
            j = 1
            For I = 2 To lastline
            For Each c In Range("A" & I & ":L" & I)
                If c.Text = strsearch Then
                    tocopy = 1
                End If
                Next c
                        If tocopy = 1 Then
                            Rows(I).Copy Destination:=Sheets("data").Rows(j)
                            j = j + 1
                        End If
                        tocopy = 0
                        Next I
                        End With
1. Im looking for a String from the given Values from the sheet "Sheet" which is a month and Doing the Search for the same String in other Sheet which is "Data "

"Data" Sheet Contains Values

Jan Feb Mar Apr May Jun July Aug Sept Oct Nov Dec

when i find the Value all i want to do is Paste that value just below that found row and found col in a new line , Im getting the address and im able to get the line and coloumn Number from the above code, all im unable to get is how do i paste those values to the new line just below the found value

Please help me find the solution

Thanks all

I'm brand new to VBA so sorry if this question is simple.

Below is my code with the line of code giving the error being: Range("FirstBlank").Select. Tried searching for a while, but this seems like a trivial problem and I can't find a solution.


	VB:
	
 CommandButton1_Click() 
     ' Selects the first blank row
    Application.Workbooks("Book2").Worksheets(1).Activate 
    Dim FirstBlank As Range 
    Set FirstBlank = Range("A65536").End(xlUp) 
    FirstBlank = FirstBlank.Offset(1, 0) 
    Range("FirstBlank").Select 
    Selection.Resize(Selection.Rows.Count, Selection.Columns.Count + 5).Select 
    Set LastCell = Nothing 
    Set FirstBlankRow = Nothing 
End Sub 

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


Hi - I am new, here and at VBA, and this is my first post. I have searched the site many times in the past two months and have found plenty of very helpful answers, and have learned quite a bit about how to work with code, so thank you for that! I cannot find anything that helps me work out how to do the following, however, and hope someone can help.

I have managed to get this far - I have put together a macro (from different threads on this site) that opens closed workbooks, copies data in one of the sheets (same sheet in each of 28 books), and pastes the data it into a master book sheet, each paste starting below the last. So that bit is working. The first bit of help I need is a line of code that will make the macro loop through a number of sub folders in a main folder. My code at the moment works as long as I specify a path that ends with the name of one subfolder, and it only loops through this subfolder. I would like the path to end at the folder that holds all the subfolders ('Workbooks' in the path below), and then add some code that tells it to apply the macro to all subfolders in this folder, so it loops through them all.

The second issue is that after the macro goes to the closed book(s), copies the data in there and pastes it into the master sheet (into columns E:FG), I then need it to go back to the workbook it just copied from, go the same sheet, to three specific cells on that sheet (FH1:FH3), copy the content, go back to the master sheet, and now repeatedly paste the content (values only and transposed) of these three cells into three cells (in columns B:D, with row number being dependent on what rows the first lot of data was copied into) next to every row it just previously pasted in for me. When it loops to the next workbook, it needs to do the same, and the three cells will have different content than the ones in the previous workbook paste.

I dont know how to define the range it needs to paste into the second time. I tried using the definition I used for the first paste (MCDrow), to tell it that it is the same rows, just different columns, but this is not working.

Here is what I have so far, which does the first part of what I need, except for needing a way to have it loop through all subfolder in the 'Workbooks' folder (at the moment it lists Barwon South West as a subfolder in that path, but I actually have multiple subfolders, not all called Barwon South (all different names) that it needs to loop through and do both the first and the second paste for. I have taken out the code I was trying to use to do the second paste, as this was not working and the code is pretty messy as it is (I sort of bumble along, being so new, and I know the code is not very clean or efficient!).

Can someone help me put in the few lines I need to loop through all my subfolders (if you give me an example I can probably extrapolate), but to get you started, three of the subfolders are Barwon South West, Eastern Region and Gippsland. And can someone help me put in the code that will do the second paste for each workbook?

Thank you so much! My hours of searching and trial and error are not working for me on this one and I am really stuck!

Here is what I have so far and sorry for the long post (I wanted to be be as clear as possible!):


	VB:
	
 Click2() 
     
     
    Application.ScreenUpdating = True 
    Dim MCDrow As Long 
     'Dim SubFolders As String
    MCDrow = ThisWorkbook.Sheets("Client Data").Range("A65536").End(xlUp).Row 
     
    Fpath = "Q:Clinical ServicesCS Statewide DatabaseWorkbooksBarwon South West" ' change to your directory
     'SubFolders = True
    Fname = Dir(Fpath & "*.xls") 
    Do While Fname  "" 
         
        ThisWorkbook.Sheets("Client Data").Unprotect 
         
        Workbooks.Open Fpath & Fname 
        Worksheets("Client Data").Activate 
        Worksheets("Client Data").Unprotect 
         
         
         
        Worksheets("Client Data").Activate 
        Range("B4:FG4", Selection.End(xlDown)).Select ''This assumes header in first row''
        Range(Selection, Selection.End(xlToRight)).Select 
        Selection.Copy Destination:=ThisWorkbook.Sheets("Client Data").Cells(MCDrow + 1, 5) 
         'need something here that does the second paste before it loopto the next book
         
        Workbooks(Fname).Close SaveChanges:=False 'or Fname
        Fname = Dir 
         
         ''' Lets get the last row for the next copy/paste '''
         
         
        MCDrow = ThisWorkbook.Sheets("Client Data").Range("E65536").End(xlUp).Row 
         
    Loop 
    Application.ScreenUpdating = True 
     
End Sub 

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


Can anybody explain how I put this formula in my “summary sheet” using VBA. I have had a go but am missing something, as I get a “compile error, expected end of statement” on this line of the code
Worksheets("Summary").Range("F65536").End(xlUp).Offset(1).Formula = "=Sh.Range("E30")"

Code below

Thanks in advance

Thanks in advance
Code:
Private Sub Complete_SummarySheet()
'Loop through sheets except those hardcoded
Dim WB As Workbook
Dim CurrentSheet As Worksheet
Dim SheetsArray As Variant
Dim Sh As Worksheet
    With Application
        .Calculation = xlManual
    End With
    
    Set CurrentSheet = ActiveSheet
    Set Wkbk = ActiveWorkbook
    
    For Each Sh In ThisWorkbook.Worksheets
    
        Select Case Sh.Name
            Case "Validation Sheet", "Control", "Summary", "Storage", "Job Sheet"
                ' do nothing
            Case Else
                Sh.Range("D4").Copy
                Worksheets("Summary").Range("B65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlValues
                Sh.Range("D6").Copy
                Worksheets("Summary").Range("D65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlValues
                Sh.Range("O6").Copy
                Worksheets("Summary").Range("E65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlValues
                Sh.Range("L4").Copy
                Worksheets("Summary").Range("C65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlValues
                Sh.Range("L30").Copy
                Worksheets("Summary").Range("I65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlValues
                Worksheets("Summary").Range("F65536").End(xlUp).Offset(1).Formula = "=Sh.Range("E30")"
                Sh.Range("E34").Copy
                Worksheets("Summary").Range("H65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlValues
                Sh.Range("T32").Copy
                Worksheets("Summary").Range("G65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlValues
        End Select

    Next Sh

    With Application
        .Calculation = xlAutomatic
   
    End With
    
End Sub


Hello all,
I've spent the last hour searching this site for how to format multiple sheets and I can't seem to get my macro to work correctly. I have some code shown below that performs various formatting tasks which I want done on all sheets in the workbook (there will be 9).

The problem is that the macro works fine on the first sheet, then instead of going to the next sheet and formatting it, it continues the same formatting on the first sheet. I'm new to VBA and this is driving me crazy.

Surely this macro could be more efficiently written, but right now I just need it to work.

I think it has something to do with an "activesheet.usedrange" line I have, but I'm not sure. Thanks in advance!!

Code:
Sub On_Trak_Row_Delete()
'
' On_Trak_Row_Delete Macro
' Deletes specific row in On Trak
'
' Keyboard Shortcut: Ctrl+r
'
' prompts use to input desired header title
ReportHeader = Application.InputBox _
    (prompt:="Input Desired Report Title , i.e. March 2008", Title:="Report Header", _
    Default:="")
Dim mywSheet As Worksheet
For Each mywSheet In ActiveWorkbook.Worksheets
    Range("4:4,6:18,29:39,41:42,48:62,66:66,67:74,87:175").Select
    Selection.Delete Shift:=xlUp
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Rows("2:35").Select
    Selection.Interior.ColorIndex = xlNone
    ActiveSheet.UsedRange.Rows("2").Interior.ColorIndex = 36
    ActiveSheet.UsedRange.Rows("5:14").Interior.ColorIndex = 36
    ActiveSheet.UsedRange.Rows("21:23").Interior.ColorIndex = 36
    ActiveSheet.UsedRange.Rows("2").Select
    'The next sections add an underline to selected rows
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    ActiveSheet.UsedRange.Rows("11").Select
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    ActiveSheet.UsedRange.Rows("21").Select
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    ActiveSheet.UsedRange.Rows("30").Select
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    'Next section wraps text on 1st row to show Agt #
    Range("C1:BW1").Select
    Range("BW1").Activate
    Selection.ColumnWidth = 7
    Rows("1:1").RowHeight = 18.75
    Rows("1:1").RowHeight = 27.75
    Rows("1:1").RowHeight = 25.5
    Range("C1:BW1").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
    End With
    Cells.Select
    With Selection.Font
        .Size = 10
    End With
    Columns("A:B").Select
    Columns("A:B").EntireColumn.AutoFit
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = "$A:$B"
    End With
    ActiveSheet.PageSetup.PrintArea = ""
     With ActiveSheet.PageSetup
        .CenterHeader = "&""Garamond,Bold""&12" & ReportHeader
        .CenterFooter = "Page &P of &N"
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.25)
        .CenterHorizontally = True
        .Orientation = xlLandscape
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
    End With
    Next mywSheet
   End Sub


Hi Excel Gurus... I am stuck with a terrible problem.. It looks simple but I am unable to resolve it.. I am trying to get records from Siebel into excel sheet. For that reason reason I open a Siebel session and do a query in siebel and get the record satisifying the query.... Unfortunately when I use a date in my search criteria, I get this error "Run Time Error 13 Type Mismatch" I have highlighted in bold where I get the error in my code below..

Code:
 
Private Sub TextBox12_Click()
Dim siebApp As SiebelWebApplication
Dim siebBusObj As SiebelBusObject
Dim revBC As SiebelBusComp
Dim isRecord As Boolean
Dim sRep As String
Dim sCompany As String
Dim sLocation As String
Dim sStep As String
Dim sProb As String
Dim sDate As String
Dim vRetDate As Variant
Dim CurDate As Date
Const DateCol = 9
CurDate = Now()
RetDate = Sheets("Users").Cells(DateCol)
r = Sheets("Users").Cells(65536, 1).End(xlUp).Row 'Get next blank row
    Sheets("Users").Cells(r, DateCol) = CurDate
'Create The Siebel WebApplication Object
Set siebWebApp = CreateObject("TWSiebel.SiebelWebApplication.1")
'Create A Business Object
Set siebBusObj = siebWebApp.GetBusObject("Revenue")
'Create a Business Component
Set revBC = siebBusObj.GetBusComp("Revenue")
With revBC
.SetViewMode 3
.ActivateField "Sales Rep"
.ActivateField "Product Line"
.ActivateField "Last Updated"
.ClearToQuery
vRetDate = Format(RetDate, "yyyy-mm-dd hh:mm:ss:000")
.SetSearchSpec "Sales Rep", "RRAJAN1"  And ([Last Updated] < vRetDate)
.ExecuteQuery True
isRecord = .FirstRecord()
            If isRecord Then
                While isRecord
 
                              sRep = .GetFieldValue("Sales Rep")
sCompany = .GetFieldValue("Sales Rep")
sProb = .GetFieldValue("Product Line")
sLocation = .GetFieldValue("Account Location")
strDate = .GetFieldValue("Last Updated")
 
 
Dim varNbRows As Long
 
 
 
    Application.ScreenUpdating = False
 
 
    ' Determining the number of records
    Sheets("Opportunity").Select
    Range("B14").Select
    varNbRows = Sheets("Opportunity").Range("B14").CurrentRegion.Rows.Count
 
    ' Going to the first empty row
    If varNbRows = 1 Then
        Range("B14").Offset(1, 0).Select
    Else
        Range("B14").Offset(varNbRows, 1).Select
    End If
 
    ' From the form to the sheet
 
    Selection.Offset(0, -1).Value = sRep
    Selection.Offset(0, 0).Value = sCompany
    Selection.Offset(0, 1).Value = sCompany
    Selection.Offset(0, 2).Value = sCompany
    Selection.Offset(0, 3).Value = sCompany
    Selection.Offset(0, 4).Value = sCompany
    Selection.Offset(0, 5).Value = sCompany
    Selection.Offset(0, 6).Value = sCompany
    Selection.Offset(0, 7).Value = sProb
    Selection.Offset(0, 8).Value = sCompany
    Call addHyperlink
 
 
    Application.ScreenUpdating = True
 
isRecord = .NextRecord()
 
                Wend
                End If
                End With
Set revBC = Nothing
Set siebBusObj = Nothing
Set siebWebApp = Nothing
 
End Sub
Please help me with this situation........

Find has several persistent values. You are only setting the search target,
so some previous use of find could set one of the other values so that the
find is not made. xlwhole vice xlpart, xlformulas vice xlvalues for
example can affect whether the target is found. If it is a date, then it
can get even more complicated.

--
Regards,
Tom Ogilvy

Stuart > wrote in message
...
>
> I am having an intermittant problem with some VBA that I am unable to
> resolve, and write in hope that someone can point me in the right
direction!
>
> The following two lines of code occasionally fail to find what is there!
>
> Sheets("VS").Columns("B").Find(what:=rng).Offset(0 , 8) =
> Sheets("VS").Columns("B").Find(what:=rng).Offset(0 , 8) + rng.Offset(0, 4)
>
> Application.StatusBar = Cells(Target.Row, 3) & " Changed from " &
> Sheets("VS").Columns("B").Find(what:=Cells(Target. Row, 3),
> LookAt:=xlWhole).Offset(0, ofSt)
>
>
> Please note, other "Fnd" commands work ok when the above two lines stop
> working!
> These lines of code are in seperate macros in a substantial workbook that
> has been wrote over many years and performs faultlessly 95% of the time,
> however, occasionally the above lines stops working. The problem is
> rectified by closing the entire application down then reopening the
> application and workbook. Everything will then work fine until the next
time
> it curiously stops.
>
> I have noted below the two subs that these lines are in. Note these are
onlt
> two macros out of about 80 in this workbook.
>
> Sub showStocka()
> Dim totI, totO, totC, totT, totR, totV, cnt, anChor
> Application.EnableEvents = False
> Application.ScreenUpdating = False
> 'initial tests for records
> If
> Len(Sheets("Reference").Range("C2").Offset(Sheets( "Reference").Range("C2")
+
> 1, 1)) 11 Then
> MsgBox "No Stock Records"
> Application.EnableEvents = True
> Exit Sub
> End If
> On Error Resume Next
> Sheets("SS").Select
>
>
Columns("I:I").Find(what:=Sheets("Reference").Rang e("C2").Offset(Sheets("Ref
> erence").Range("C2") + 1, 1)).Select
> If Err Then
> MsgBox "Macro Problem, main reference not found on stock
sheet"
> Sheets("Stock Control").Select
> Application.EnableEvents = True
> Exit Sub
> End If
> On Error GoTo 0
>
> 'prepare VS sheet and copy in data
> Sheets("VS").Select
> ActiveSheet.Unprotect
> Range("$A$1", Selection.SpecialCells(xlLastCell)).ClearContents
> Sheets("SS").Select
> Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row,
> 1).End(xlDown).Offset(0, 29)).Select
> Selection.Copy
> Sheets("VS").Select
> Range("B3").PasteSpecial Paste:=xlValues
> Sheets("SS").Range("P1:AD1").Copy
> Range("Q3").PasteSpecial Paste:=xlValues
> anChor = Range("B3").End(xlDown).Offset(1, 0).Address
>
> Sheets("OX").Select
> Range(Range("A1"), Range("A30000").End(xlUp)).Select
> cnt = 0
> For Each rng In Selection
> If Len(rng) = 5 And Left(rng, 2) = Sheets("VS").Range("C3") Then
> On Error Resume Next
> Sheets("VS").Columns("B").Find(what:=rng).Offset(0 , 8) =
> Sheets("VS").Columns("B").Find(what:=rng).Offset(0 , 8) + rng.Offset(0, 4)
> If Err Then
> On Error GoTo 0
> Sheets("VS").Range(anChor).Offset(cnt, 0) = rng
> Sheets("VS").Range(anChor).Offset(cnt, 1) =
> rng.Offset(0, 1)
> Sheets("VS").Range(anChor).Offset(cnt, 2) =
> rng.Offset(0, 2)
> Sheets("VS").Range(anChor).Offset(cnt, 3) =
> rng.Offset(0, 3)
> Sheets("VS").Range(anChor).Offset(cnt, 8) =
> rng.Offset(0, 4)
> Sheets("VS").Range(anChor).Offset(cnt, 11) =
> rng.Offset(0, 7)
> Sheets("VS").Range(anChor).Offset(cnt, 12) =
> rng.Offset(0, 8)
> Sheets("VS").Range(anChor).Offset(cnt, 13) = "N"
> cnt = cnt + 1
> End If
> On Error GoTo 0
> End If
> Next rng
> Sheets("VS").Select
> Range("B4").Select
> If Range("B5") "" Then Range("B4", Cells(4, 2).End(xlDown)).Select
> totV = 0: totI = 0: totO = 0: totC = 0: totR = 0: totT = 0
> For Each rng In Selection
> rng.Offset(0, -1) = Right(rng, 3) / 1
> totV = totV + rng.Offset(0, 9) * rng.Offset(0, 11)
> totT = totT + rng.Offset(0, 11)
> totR = totR + rng.Offset(0, 12)
> If rng.Offset(0, 9) > 0 Then
> totI = totI + 1
> Else
> totO = totO + 1
> End If
> If rng.Offset(0, 10) = "X" Then totC = totC + 1
> Next rng
> Range("A1") = totV
> Range("B1") = totI
> Range("C1") = totO
> Range("D1") = totC
> Range("E1") = totR / totT
>
> 'sets view
> Columns("E").ColumnWidth = 0
> Columns("F").ColumnWidth = 0
> Columns("Q").ColumnWidth = 0
> Columns("H").ColumnWidth = 0
> Range("A4:AA4").Select
> ActiveWindow.Zoom = True
> If Range("A5") "" Then
> Range("A4", Cells(4, 1).End(xlDown).Offset(0, 31)).Select
> Range("A4", Cells(4, 1).End(xlDown).Offset(0, 31)).Sort
> Key1:=Range("A4"), Order1:=xlAscending
> End If
> Range("A2") = "A4" 'see sort routine
> Range("A4").Select
> ActiveSheet.DrawingObjects("ModeBox").Characters.T ext = "View Only"
> ActiveSheet.DrawingObjects("ViewOnlyButGroup").Bri ngToFront
> ActiveSheet.DrawingObjects("EditViewButGroup").Sen dToBack
> ActiveSheet.DrawingObjects("OrderButGroup").SendTo Back
> ActiveSheet.DrawingObjects("But_ViewOrder").SendTo Back
>
> Columns("A:AE").Locked = True
> ActiveSheet.Protect
> Application.OnTime Now, "fixView"
> With ActiveWindow
> .DisplayHeadings = False
> .DisplayHorizontalScrollBar = False
> .DisplayWorkbookTabs = False
> .DisplayVerticalScrollBar = True
> End With
> With Application
> .DisplayFormulaBar = False
> .DisplayStatusBar = True
> End With
> Application.EnableEvents = True
> glb_LineOnOff = 0
> End Sub
>
>
> Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
> Dim ofSt As Integer
> If Target.Interior.ColorIndex = 36 Then
> If Target.Column > 6 Then
> ofSt = Target.Column + 1
> Else
> ofSt = Target.Column - 3
> End If
> Application.StatusBar = Cells(Target.Row, 3) & " Changed from "
&
> Sheets("VS").Columns("B").Find(what:=Cells(Target. Row, 3),
> LookAt:=xlWhole).Offset(0, ofSt)
> Else
> Application.StatusBar = False
> End If
> End Sub
>
>

Hi,

I am working on a macro that will place an "x" in column D and B if column S contains a date that is less than 1 year old. I'm thinking it will look somewhat like this but I don't know about using the dates so I need some help in that area of code. the line of code I need help on is this:

"if prevrev.value < now and prevrev.value > 1 year ago then"

see below:

Sub previously_reviewed()

Dim finalrow As Long
    ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Select
    finalrow = ActiveCell.Row

Dim prevrev As Long
    For Each prevrev In Range("S", Range("S" & finalrow).End(xlUp))
      if prevrev.value < now and prevrev.value > 1 year ago then
         Range("D" & prevrev.Row) = "x"
         Range("B" & prevrev.Row) = "x"
      End If
    Next prevrev
End Sub
Once I get that, eventually what I would like to do it make 'now' equal to the last 8 digits of the file name (ie. xyzab20090831.xls) the macro will run on instead of the date I run the macro.

If that doesn't make sense let me know and I'll explain.

I'll post an attachment as an example of what I'm working on. thanks!
Curbster

Hi, im struggling with the syntax of a vlookup formula (which works fine until i try to implement it in vba), when i enter it as a formula into the spreadsheet it looks like this:



The code below works fine up until the last line where im trying to put a vlookup formula into the range R8:AD(lastrow).
Im sure nearly all ive done is good but the formulas are not appearing in the range of cells ive specified for some reason.

Public Sub open_previous_wd()

AddIns("Analysis ToolPak").Installed = True

    'Find current month and year
    CurrMonth = MonthName(Month(Date))
    CurrYear = Year(Now())

    'Create current days filename (file_name1)
    file_name0 = Now()
    file_name1 = LTrim(Str(Day(file_name0))) & "." & LTrim(Str(Month(file_name0))) & "."
& LTrim(Str(Year(file_name0))) & ".xls"

    'Create previous days filename (file_name2)
    Dim file_name As String
    On Error Resume Next
    Act_date = Now()
    ' if the actual date is on a monday
    If Weekday(Act_date) = 2 Then
    ' then subtract 3 days from actual date to get fridays date
    open_date = Act_date - 3
    Else
    'else if not monday then set open date to yesterday
    open_date = Act_date - 1
    End If
    file_name2 = LTrim(Str(Day(open_date))) & "." & LTrim(Str(Month(open_date))) & "." &
LTrim(Str(Year(open_date))) & ".xls"

'Open Template'
    Workbooks.Open Filename:="C:UsersCFDesktopprojectTEMPLATE.xls"
    Windows("TEMPLATE.xls").Activate
    Sheets("DATA").Select

'Open Yesterays report
    Workbooks.Open Filename:="C:UsersCFDesktopproject" & file_name2
    Windows(file_name2).Activate

'Open Todays report, copy data, paste into open 'Template'
    Workbooks.Open Filename:="C:UsersCFDesktopproject" & file_name1
    Windows(file_name1).Activate
    Sheets("Sheet1").Select
    Range("A9:O9").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("TEMPLATE.xls").Activate
    Sheets("DATA").Select
    Range("A8").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A7").Select

'Vlookup formula with a dynamic previous working days date

    Dim path2 As String
    path2 = "C:UsersCFDesktopproject" & file_name2
   
'something goes wrong after this point

    Dim lastrow As Long
    lastrow = Worksheets("DATA").Range("B65536").End(xlUp).Row

    Dim RNGE1 As Range
    RNGE1 = Workbooks(path2).Worksheets("Sheet1").Range("A7:O7000")
    
    Range("Q8").Select
    Range("Q8:AD7000").Formula =
"=IF((VLOOKUP($A8,RNGE1,$Q6,FALSE)<>B8,(VLOOKUP($A8,RNGE1,$Q6,FALSE)),""OK"")"

End Sub

Ive put some comments through the code. Also if it helps, what it is im trying to do is as follows:
find todays date and derive the last working days date.create a filename using both.open todays report and copy into TEMPLATE.count the number of rows in todays report (which is now in TEMPLATE).apply the vlookup formula to the appropriate range.the formula will compare todays report to yesterdays.

Hello All,

I am new to the Forum and relatively new to VBA programming. Here is the problem I am having:

At one point within my code, I am attempting to Remove Duplicates. However, once the macro gets to that line, it throws a Run-time error 9. So, I decided to take just that line and put it into a separate macro. I then put a Call within the original code, and it seems to work just fine???? I will post the code below just in case that may be helpful. Thanks for any insights.

Option Base 1
Sub Step_4_Purchasing_Detail()
    
    Dim fillVar As Long
    Dim getNamc As String
    Dim summaryFillVar As Long
    Dim icRef As Variant
    Dim startVar As Long
    Dim endVar As Long
    Dim icArray() As String
    Dim icCount As Long
    
    Application.ScreenUpdating = False

    getNamc = Application.InputBox(Prompt:="Enter NAMC.", Title:="NAMC", Type:=2)

    Sheets("AAPJ182").Select
    Columns("A:H").Select
    Selection.Copy

    ' Remove rows and columns not needed by Purchasing
    Sheets("Purchasing").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Rows("1:2").Select
    Selection.Delete Shift:=xlUp
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp

    fillVar = Application.WorksheetFunction.CountA(Range("A:A"))

    ' Add NAMC column
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Formula = "NAMC"
    Range("A2").Value = getNamc
    Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A" & fillVar)

    Columns("A:H").Select
    ActiveWorkbook.Worksheets("Purchasing").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Purchasing").Sort.SortFields.Add Key:=Range( _
        "B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Purchasing").Sort
        .SetRange Range("A:H")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Sheets("InterCompany").Select
    icCount = Application.WorksheetFunction.CountA(Range("H:H"))
    
    ReDim icArray(icCount)
    
    For i = 3 To icCount + 1
        icArray(i - 2) = Range("H" & i).Value
    Next i
    
    Sheets("Purchasing").Select

    For i = 1 To icCount - 1
        Range("B1").Select
        Set icRef = Columns("B:B").Find(What:=icArray(i), After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                False, SearchFormat:=False)
        If Not icRef Is Nothing Then
            Range("B1").Select
            Columns("B:B").Find(What:=icArray(i), After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                False, SearchFormat:=False).Activate
            startVar = ActiveCell.Row
            Range("B1048576").Activate
            Columns("B:B").Find(What:=icArray(i), After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:= _
                False, SearchFormat:=False).Activate
            endVar = ActiveCell.Row
            Rows(startVar & ":" & endVar).Select
            Selection.Delete Shift:=xlUp
        End If
    Next i
    
    Columns("A:H").Select
    ActiveWorkbook.Worksheets("Purchasing").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Purchasing").Sort.SortFields.Add Key:=Range( _
        "B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Purchasing").Sort.SortFields.Add Key:=Range( _
        "D:D"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Purchasing").Sort.SortFields.Add Key:=Range( _
        "E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Purchasing").Sort
        .SetRange Range("A:H")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' Create Summary data from Detail data
    Columns("A:E").Select
    Selection.Copy
    Range("J1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Columns("G:G").Select
    Selection.Copy
    Range("O1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False


    ' This is the line causing the error. If I delete it and uncomment the Call, it seems to work fine???
    ActiveSheet.Range("$J:$O").RemoveDuplicates Columns:=Array(2, 3, 4), _
        Header:=xlNo

    'Call Macro2
        
    summaryFillVar = Application.WorksheetFunction.CountA(Range("J:J"))
    
    ' Insert formulae and headers
    Range("N1").Formula = "AGING DATE"
    Range("O1").Formula = "UNIT PRICE"
    Range("P1").Formula = "QTY"
    Range("Q1").Formula = "AMOUNT"
    Range("R1").Formula = "BUYER CODE"
    Range("S1").Formula = "BUYER NAME"
    Range("T1").Formula = "A/M"
    Range("U1").Formula = "MANAGER"
    
    Range("P2").Formula = _
        "=SUMIFS($F:$F,$B:$B,K2,$C:$C,L2,$D:$D,M2)"
    Range("Q2").Formula = _
        "=SUMIFS($H:$H,$B:$B,K2,$C:$C,L2,$D:$D,M2)"
    Range("R2").Formula = _
        "=VLOOKUP(K2,'Buyer Info'!$A:$B,2,FALSE)"
    Range("S2").Formula = _
        "=VLOOKUP(K2,'Buyer Info'!$A:$C,3,FALSE)"
    Range("T2").Formula = _
        "=VLOOKUP(K2,'Buyer Info'!$A:$D,4,FALSE)"
    Range("U2").Formula = _
        "=VLOOKUP(K2,'Buyer Info'!$A:$E,5,FALSE)"
    Range("P2:U2").Select
    Selection.AutoFill Destination:=Range("P2:U" & summaryFillVar)
    Columns("J:U").Select
    
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1:H1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("A1").Value = "DETAIL"
    Range("J1:U1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("J1").Value = "SUMMARY"
    Range("A1").Select
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Range("J1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("G3:H1048576").Select
    Selection.Style = "Currency"
    Range("O3:O1048576").Select
    Selection.Style = "Currency"
    Range("Q3:Q1048576").Select
    Selection.Style = "Currency"
    Range("N3:N1048576").Select
    Selection.NumberFormat = "m/d/yyyy"
    Range("E3:E1048576").Select
    Selection.NumberFormat = "m/d/yyyy"
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    
    Application.ScreenUpdating = True

End Sub
Sub Macro2()

    ActiveSheet.Range("$J:$O").RemoveDuplicates Columns:=Array(2, 3, 4), _
        Header:=xlNo
        
End Sub


Hey I'm trying to convert the following formula to be entered in automatically in VB


Below is the code I have so far (LastRow is last row in current sheet, LR is last row in Data and LR1 is last row in HC). I get a error when running and the debugger highlights the longest line (with the formula). I have run the entry using Macro record and those results are posted below my code, the only problem is I don't know how to edit that particular format to look like my old format. I want to maintain this format so if anyone else uses my workbook it will be easier to follow

Sub FillinFormula()
    Dim LastRow As Long
    Dim LR As Long
    Dim LR1 As Long
    
    LR = Sheets("Data").Range("B" & Rows.Count).End(xlUp).Row
    LR1 = Sheets("HC").Range("B" & Rows.Count).End(xlUp).Row
    LastRow = Range("A" & Rows.Count).End(xlUp).Row


  Range("D2").Formula = "=(SUMPRODUCT(--(HC!$A$3:$A$" & LR1 & "=$B2),--(HC!$B$3:$B$"
& LR1 & "=$C2),HC!C$3:C$" & LR1 & ")*INDEX(Data!C$2:C$" & LR &
",MATCH($A2&" & "@" & "&$B2,INDEX(Data!$A$2:$A$" & LR &
"&""@""&Data!$B$2:$B$" & LR & ",0),0)))/SUMIF(HC!$A$3:$A$" & LR
& ",$B2,HC!C$3:C$" & LR & ")"

    Range("D2:N2").FillRight
    
    With Range("D2:N" & LastRow)
        .FillDown
        .Copy
        Range("D2").PasteSpecial xlPasteValues
    End With

    Range("A2").Select
End Sub



I think the problem is somewhere in the fact that the formula uses quotation marks and the @ sign but those are understood differently in VBA

Any help or suggestions would be appreciated

Hi,

I'm still playing around and trying to explore the VBA ocean :cry:

The code below is self explanatory but it does not undo the border related formatting. Can you please guide and help me figure out my mistake. The attached image shows the worksheet that I am using.


	VB:
	
 Exercise5() 
     ' This code is supposed to do the following:
     ' If the cell is highlighted with yellow fill, format it's borders, display a dialog Box/MsgBox
     ' with some information about the cell and when the user clicks OK on the MsgBox,
     ' it should [B][SIZE="4"]undo[/SIZE][/B] all border related formatting
     
    Dim Rng As Range, MyCell As Range 
    Dim irow As Long 
     
    Application.ScreenUpdating = False 
     
    Set Rng = Worksheets(1).Cells(1, 1) 
    irow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row 
    Set Rng = Rng.Resize(irow - Rng.Row + 1, 1) 
     
    On Error Resume Next 
     
    For Each MyCell In Rng.Cells 
        If MyCell.Interior.ColorIndex = 6 Then 
             
            [B][COLOR="Red"][SIZE="4"] ' Tried both of the following lines MyCell.Activitate and MyCell.Select
             ' but could not get the cell to be selected.
             ' Can you please help me understand why I am unable to
             ' get the cell highlighted?[/SIZE][/COLOR][/B]
             '     MyCell.Select
             '     MyCell.Activate
             
            With MyCell 
                .BorderAround LineStyle:=xlDash, Weight:=xlThick, ColorIndex:=5 
            End With 
             
            MsgBox "Cell Address = " & MyCell.Address & vbLf & _ 
            "Interior.ColorIndex = " & MyCell.Interior.ColorIndex & vbLf & _ 
            "Cell.Value = " & MyCell.Value 
             
             '[B][COLOR="Red"]The code below [B][SIZE="4"]does not undo[/SIZE][/B] the border related formatting that was
done above[/COLOR][/B]
            With MyCell 
                .BorderAround LineStyle:=xlContinuous, Weight:=xlThin,
[INDENT][INDENT][INDENT]_ColorIndex:=xlColorIndexAutomatic[/INDENT][/INDENT][/INDENT]      End With 
                 
            End If 
        Next MyCell 
         
        Application.ScreenUpdating = True 
         
    End Sub 

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

In the code below I am trying to sort each worksheet within the same loop but I am having trouble getting this to happen. So far I can set up the code to sort a single sheet, but not each sheet. I dont know how to say "after you have sorted this sheet you should move to the next"

Here is the specific code I have issue with. It doesnt work because of my selection method, specifically VBA is having issue with this line


	VB:
	
 wsWS.Range("a5").Select 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
that code is nested here


	VB:
	
 
If wsWS.Name  "Tracking Sheet" And wsWS.Range("a6").Value  "" Then 'sort ascending
    wsWS.Range("a5").Select 
    Selection.sort Key1:=Range("A6"), Order1:=xlAscending, Header:=xlGuess, _ 
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 
End If 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
All of the code is below. Basically I am telling VBA to work through each worksheet and perform various funtions, and I would like sorting to be among them


	VB:
	
 report() 
    Dim wsTracking As Worksheet 
    Dim wsCrit As Worksheet, wsNew As Worksheet, wsWS As Worksheet, wsSort As Worksheet 
    Dim rngIP As Range, rngPN As Range, rngDD As Range, rngDR As Range, rngCN As Range 
    Dim LastRow As Long, LastRowCrit As Long, I As Long, lngMax As Long 
    Dim intTracking As Integer, intFivedays As Integer 
     
    Set wsTracking = Worksheets("Tracking Sheet") 
    LastRow = wsTracking.Range("A" & Rows.Count).End(xlUp).Row 
    Set wsCrit = Worksheets.Add 
     
    wsTracking.Range("E2:E" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("E2"), Unique:=True 
    LastRowCrit = wsCrit.Range("E" & Rows.Count).End(xlUp).Row 
     
    Application.ScreenUpdating = False 
     
    For I = 3 To LastRowCrit 'apply filter to tracking sheet. extract unique estimator names and create worksheets with those
names
        Set wsNew = Worksheets.Add 
        wsNew.Name = wsCrit.Range("E" & I).Value 
        wsNew.Range("a3").Value = "Estimator" 
        wsNew.Range("a5").Value = "IP Number" 
        wsNew.Range("b5").Value = "Project Name" 
        wsNew.Range("c5").Value = "Due Date" 
        wsNew.Range("d5").Value = "Days Remaining" 
         
    Next I 
     
    For Each wsWS In Worksheets 'populate each worksheet with the estimators information
        For intTracking = 3 To LastRow 
            Set rngIP = wsWS.Range("A65536").End(xlUp).Offset(1, 0) 
            Set rngPN = wsWS.Range("b65536").End(xlUp).Offset(1, 0) 
            Set rngDD = wsWS.Range("c65536").End(xlUp).Offset(1, 0) 
            Set rngDR = wsWS.Range("d65536").End(xlUp).Offset(1, 0) 
             
             
            If wsWS.Name = wsTracking.Range("e" & intTracking).Value And wsWS.Name  "Tracking Sheet" _ 
            And wsTracking.Range("i" & intTracking).Value  "COMPLETE" _ 
            And wsTracking.Range("i" & intTracking).Value >= 1 Then 
                wsTracking.Range("a" & intTracking).Copy rngIP 
                wsTracking.Range("b" & intTracking).Copy rngPN 
                wsTracking.Range("h" & intTracking).Copy rngDD 
                wsTracking.Range("i" & intTracking).Copy rngDR 
                wsWS.Range("b3").Value = wsWS.Name 
                 
            End If 
        Next intTracking 
         
        lngMax = wsWS.Range("a65536").End(xlUp).Row 
         
        For intFivedays = 6 To lngMax 'if the days remaining is =0 then highlight that row
            If wsWS.Range("D" & intFivedays).Value = 0 Then 
                wsWS.Range("A" & intFivedays, "D" & intFivedays).Interior.ColorIndex = 41 
            End If 
             
            If wsWS.Name  "Tracking Sheet" And wsWS.Range("a6").Value  "" Then 'sort ascending
                wsWS.Range("a5").Select 
                Selection.sort Key1:=Range("A6"), Order1:=xlAscending, Header:=xlGuess, _ 
                OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 
            End If 
        Next intFivedays 
         
        If wsWS.Name  "Tracking Sheet" Then 
            wsWS.Cells.EntireColumn.AutoFit 
        End If 
    Next wsWS 
     
    Application.DisplayAlerts = False 
    wsCrit.Delete 
    Application.DisplayAlerts = True 
End Sub 

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

Hello, all.

I was messing around trying to get better with VBA and hit a stumbling block. I have attached the simple workbook that I was using, and pasted the code below if you'd like to check that out first:


	VB:
	
 Finished_Click() 
     
    Range("B1:B2").Select 
    Selection.Copy 
     
    Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial _ 
    Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True 
     
    Range("C8:F8").Select 
    Selection.Copy 
     
    Range("A65536").End(xlUp).Offset(0, 2).PasteSpecial _ 
    Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
     
    Range("E8").Select 
    Selection.Activate 
     
End Sub 
 
Private Sub Worksheet_Activate() 
     
    Dim cbCVals 
    Dim i As Integer 
     
    cbCVals = Array("Axle", "Wheel") 
     
    For i = 0 To 1 
        cbComponents.AddItem cbCVals(i) 
        cbComponents2.AddItem cbCVals(i) 
    Next i 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
K, now here are my issues:

1) For both PasteSpecials, I need the copied data from the Invoice worksheet to be pasted into the Database worksheet. I've tried and tried to modify the code to do this, but have been unsuccessful being that I'm an amateur at this.

2) The "Finished" button in Invoices is what triggers the Finished_Click macro. This basically adds a record to the database, line by line, each time it's selected. Now, I'd like to have 5 ComboBoxes in the invoices sheet, because obviously more than one Component may be ordered. So, instead of having 5 "Finished" buttons to add individual records to Database, I'd like there to be one "Finished" button that ONLY sends the records for whatever Components are ordered. The only way I know how to get the information for each Component into Database right now is to copy a range from Invoices, and paste the whole range. So, I'd potentially be pasting empty records into Database if only 3 Components are ordered. How do I get around this?

I'd appreciate any help with this. Thanks.

Bubbis Thedog

I have a problem to copy worksheets from multiple workbooks based on a cell value to a master copy. My supervisor has been nagging at me to come out with program that will help to retrieve the data. As my VBA knowledge is so bad that i really need the help from some of the experts in this forum.

Every month i need to get the data from 120 excel files"Day". Example I only wanted the Cell "A1"=1 data i will key 1 at the cell "A1" of the master copy, i need the VBA to help me open up all the 120 files and look through all the worksheets to see if their cell "A1" =1.If it is true, it will copy the whole table and paste it back to my master copy "Shift 1". If not it will go to the next worksheet (Each workbooks has only 3 worksheets), after the 3rd worksheet, it will close the workbook and carry on open up one by one all the 120 workbooks.

Thank you Auto Merged Post Until 24 Hrs Passes;

Dear experts

The below code is what i have done. I only able to copy out the worksheet but have no idea how to select the worksheet which i wanted. eg like mastercopy cell A1 got value = 1 choose only those sheet with cell value = 1.

Can anyone one please help me.


	VB:
	
 Importdata() 
     
    Dim x As Long, z As Variant 
    Dim bk As Workbook, sh As Worksheet 
    Dim sh1 As Worksheet 
    Dim sh2 As Worksheet 
    Dim sh3 As Worksheet 
     
     '  Change the next line to reflect the proper
     '  name and workbook where the data will be
     '  consolidated
     
     ' Select the directory to open
    SaveDriveDir = CurDir 
    MyPath = "Q:/" 
    ChDrive MyPath 
    ChDir MyPath 
     
    Set sh = Workbooks("Mastercopy.xls").Worksheets("Shift1") 
    z = Application.GetOpenFilename(FileFilter:= _ 
    "Excel files (*.xls), *.xls", MultiSelect:=True) 
    If Not IsArray(z) Then 
        MsgBox "Nothing selected" 
        Exit Sub 
    End If 
     
     'Open loop for action to be taken on all selected workbooks.
     
    For x = 1 To UBound(z) 
         
         'Open the workbook(s) that were selected.
        Set bk = Workbooks.Open(z(x)) 
         'Check if sheet Date exists
        On Error Resume Next 
         
        Set sh1 = bk.Worksheets("Sheet1") 
        Set sh2 = bk.Worksheets("Sheet2") 
        Set sh3 = bk.Worksheets("Sheet3") 
         
        On Error Goto 0 
         ' if it exists, copy the data
        If Not sh1 Is Nothing Then 
            Set rng = sh1.Range("A2:K5") 
            Set rng1 = sh.Cells(Rows.Count, 1).End(xlUp)(2) 
            rng.Copy 
            rng1.PasteSpecial xlValues 
            rng1.PasteSpecial xlFormats 
        End If 
         
         
        If Not sh2 Is Nothing Then 
            Set rng3 = sh2.Range("A2:K5") 
            Set rng4 = sh.Cells(Rows.Count, 1).End(xlUp)(2) 
            rng3.Copy 
            rng4.PasteSpecial xlValues 
            rng4.PasteSpecial xlFormats 
        End If 
         
         
        If Not sh3 Is Nothing Then 
            Set rng5 = sh3.Range("A2:K5") 
            Set rng6 = sh.Cells(Rows.Count, 1).End(xlUp)(2) 
            rng5.Copy 
            rng6.PasteSpecial xlValues 
            rng6.PasteSpecial xlFormats 
            Application.DisplayAlerts = False 
        End If 
         
         'Close the District workbook without saving it.
        bk.Close False 
    Next x 
     
     'Message box to inform user the job is complete.
    MsgBox "The import is complete.", 64, "Done !!" 
End Sub 

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


I am trying to create a workbook for our traffic dept. to track all new orders. This workbook needs to stay open all the time so the traffic guy can see when a new order comes in.

I am fairly green to vba programming, so please be gentle...

The code below is what I currently have that works fine if the "traffic.xlsm" sheet is closed, but if it is opened, I get "Traffic.xlsm is already open. Reopening will cause any changes you made to be discarded. Do you want to reopen Traffic.xlsm?"

I thought that by sharing the Traffic.xlsm spreadsheet, that this wouldn't be an issue, but it obviously isn't working as intended.

Can anyone tell me how we can keep Traffic.xlsm open all the time and still allow this code to execute from the main spreadsheet that populates Traffic.xlsm?

I thought if I just removed the last line, "ActiveWindow.Close", that it would work, but I'm obviously missing something more.

'Traffic - Server
    Sheets("Traffic").Select
    Sheets("Traffic").Range("A3:Y3").Select
    Selection.Copy
    Workbooks.Open Filename:="CAB-NET-SVR1Traffictraffic.xlsm"
    Sheets("traffic").Range("A65536:Y65536").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Paste
    
    ActiveWorkbook.Save
    ActiveWindow.Close



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