Posts by philb1

philb1 · Jun 10th 2016

Re: Why is Option Explicit optional?

I'm a self taught VBA coder and when I first started it was hard enough fixing errors when Option Explicit wasn't in use. There was the occasional typo of my own doing, but it was mainly trying to figure out what all the different Dim declarations actually meant. ie, Long for numbers, Double for really big numbers etc etc. I often used to get them wrong or mix them up & many a time I thought of saying "to h*** with it" & use Variant for everything. Eventually it all sank in & now I use Option Explicit by default, it makes life so much easier, but not understanding the basics like ranges, objects etc made debugging a nightmare for me

philb1 · Jun 3rd 2016

Re: Errors Keep Popping Up

Hi ekfasy

I've got your code working & I presume it's putting the copied data where you want it. I haven't changed anything like that.
It's easier if you select the file you want from the dropdown before you start the macro, you won't have to stop the routine to do the check. I put a test in to compare the file name you selected to open with the name in the cell J1. If the J1 text is in the filename selected, it will run the routine, if not it will terminate.

The causes of the errors were

1) Matching of hyphens "-" and underscores "_". You had hyphens in the dropdown and underscores in the file names. The file you selected from the file open window won't match Cell J1 causing the Select Case part of the macro to never run & routine would exit every time.

2) When copying the data from the HIJ_123 etc workbook, you didn't fully qualify where the code was supposed to be copied from. You used ".Range(.Cells(11, 1), .Cells(z, 1)).Copy" when it needed to be "Wb2.Worksheets("Quote").Range(.Cells(11, 1), .Cells(z, 1)).Copy"

I changed a couple of things to make the code more readable, any questions, gimme a shout. The code is below & the file is attached for you to check out
If you have the editor open place a break just after myFile = application.blah blah by putting the mouse cursor on the left hand frame of the window, right next to the next line down & left click, select the file you want to open in J1, press F5 to start the macro, select the file to open & the macro will stop at the break. You can then step through the macro by pressing F8 to check out the code. Apologies if you already knew how to do all that

Cheers

Code

'Opens up a window for user to browse and choose which file to open up
Sub BrowseFileToOpen()
     
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With




    Dim Wb1 As Workbook ' This Workbook (ABC Quote To Customer)
    Dim Wb2 As Workbook ' The Other Workbook
    Dim lr As Long, rCount As Long, z As Long, y As Long
    Dim BkName As String ' Name of the file chosen with GetOpenFileName
    Dim Vendor As String ' Holds contents of Wb1 Cell J1
    Dim myFile As String 'Using string will evaluate to an error








    Set Wb1 = ThisWorkbook
    Vendor = Sheet1.Range("J1")




     'Restrict browsing other files - Only excel files
     
    myFile = Application.GetOpenFilename("Excel Files (*.xl*),*.xl*", , "Choose File", "Open", False)




    BkName = Dir$(myFile)
    
'   Test if selected workbook is the same as that in cell J1
'   If so, open it. If not, let user know & exit routine
    If InStr(1, BkName, Vendor, vbTextCompare) = 0 Then
        
        MsgBox " File Names Don't Match"
        
        Sheet1.Range("J1").ClearContents
    
        GoTo TheExit ' End routine including resetting EnableEvents etc
        
    Else ' Open the file
        
'   Set Open Workbook Variable.
    On Error Resume Next ' Returns Error If Not Open
        Set Wb2 = Workbooks(BkName)
    On Error GoTo 0




'   Test If External Workbook Is Open. If Not, Open It
    If Nothing Is Wb2 Then
        Workbooks.Open (myFile)
        Set Wb2 = Workbooks(BkName)
    Else: End If
     
      
 'coding for drop-down menu
 
Select Case Vendor




     'If "HIJ-123" is chosen in the drop-down box:
Case Is = "HIJ_123"
     'create macro for HIJ-123
     
    With Wb2.Worksheets("Quote") 'Change the name to match your worksheet.
    
        lr = .Columns("A:E").Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        
        rCount = lr - 21
        
        Wb1.Worksheets("ABC Quote").Rows("24:" & CStr(24 + rCount)).EntireRow.Insert
        
        Wb2.Worksheets("Quote").Range(.Cells(21, 1), .Cells(lr, 1)).Copy _
        Destination:=Wb1.Worksheets("ABC Quote").Range("B24") 'Change the name to match your worksheet.




        Wb2.Worksheets("Quote").Range(.Cells(21, 2), .Cells(lr, 2)).Copy _
        Destination:=Wb1.Worksheets("ABC Quote").Range("C24") 'Change the name to match your worksheet.




        Wb2.Worksheets("Quote").Range(.Cells(21, 3), .Cells(lr, 3)).Copy _
        Destination:=Wb1.Worksheets("ABC Quote").Range("D24") 'Change the name to match your worksheet.




        Wb2.Worksheets("Quote").Range(.Cells(21, 4), .Cells(lr, 5)).Copy _
        Destination:=Wb1.Worksheets("ABC Quote").Range("E24") 'Change the name to match your worksheet.




    End With




    Wb2.Close False ' Close the other workbook without saving




    Sheet1.Range("J1").ClearContents




    MsgBox "HIJ_123 quote conversion is complete."
    
    GoTo TheExit




     'If "HIJ-456" is chosen in the drop-down box:
Case Is = "HIJ_456"








     'create macro for HIJ-456 quote




    With Wb2.Worksheets("Quote") 'Change the name to match your worksheet.
    
        z = .Columns("A:E").Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        
        y = z - 11
        
        Wb1.Worksheets("ABC Quote").Rows("24:" & CStr(24 + y)).EntireRow.Insert
        
        Wb2.Worksheets("Quote").Range(.Cells(11, 1), .Cells(z, 1)).Copy _
        Destination:=Wb1.Worksheets("ABC Quote").Range("C24") 'Change the name to match your worksheet.




        Wb2.Worksheets("Quote").Range(.Cells(11, 2), .Cells(z, 2)).Copy _
        Destination:=Wb1.Worksheets("ABC Quote").Range("D24") 'Change the name to match your worksheet.




        Wb2.Worksheets("Quote").Range(.Cells(11, 3), .Cells(z, 3)).Copy _
        Destination:=Wb1.Worksheets("ABC Quote").Range("B24") 'Change the name to match your worksheet.




        Wb2.Worksheets("Quote").Range(.Cells(11, 4), .Cells(z, 5)).Copy _
        Destination:=Wb1.Worksheets("ABC Quote").Range("E24") 'Change the name to match your worksheet.




    End With




    Wb2.Close False ' Close the other workbook without saving




    Sheet1.Range("J1").ClearContents




    MsgBox "HIJ_456 quote conversion is complete."




    GoTo TheExit




End Select
 
End If
 
TheExit:
With Application
    .DisplayAlerts = True
    .EnableEvents = True
    .ScreenUpdating = True
End With
 
Exit Sub
 
End Sub

Display More

philb1 · Jun 2nd 2016

Re: Copying all non-empty cells from ws1 to ws2 and copy corresponding column title

Not sure why that's happening, maybe there's a difference between the sample you provided & the real workbook.

Try the attached, the button to press is on the compressed worksheet

Cheers

philb1 · Jun 2nd 2016

Re: Copying all non-empty cells from ws1 to ws2 and copy corresponding column title

Hi dmi123
I think I understood you. You wanted the column header for the first one found Q39 in B2 and 2 in C2 etc

If so the code below will do that on the example file you provided

Cheers

Code

Option Explicit




Sub DataTransfer()




Dim arrData() As Variant, arrComp() As Variant
Dim Lrow As Long, i1 As Long, i2 As Long, i3 As Long, Z As Long




'   Find last used row of  data on raw data sheet column A
    Lrow = Sheet1.Columns(1).Find(What:="*", LookIn:=xlValues, _
                LookAt:=xlPart, Searchorder:=xlByRows, _
                searchdirection:=xlPrevious, MatchCase:=False, searchformat:=False).Row




ReDim arrData(1 To Sheet1.Cells(Lrow, 1), 1 To 121)
    arrData = Sheet1.Range("A1:DQ" & Lrow).Value2
    
ReDim arrComp(2 To Lrow, 1 To 16)
    
    For i1 = 2 To UBound(arrData)
        i3 = 1 ' Column Number For Compressed Sheet
            Z = 0 ' Counter
            
            For i2 = 2 To 121
            
                If Not IsEmpty(arrData(i1, i2)) Then
                    arrComp(i1, i3) = arrData(1, i2)
                    arrComp(i1, i3 + 1) = arrData(i1, i2)
                    Z = Z + 1
                    i3 = i3 + 2
                    If Z = 8 Then Exit For
                End If
            
            Next i2
            
    Next i1
    
'   Paste data on to Compressed sheet
    Sheet2.Range("B2").Resize(UBound(arrComp, 1) - 1, UBound(arrComp, 2)).Value2 = arrComp




    Erase arrData: Erase arrComp
    
Exit Sub
        
        




End Sub

Display More

philb1 · Apr 5th 2016

Re: Copying X amount of names from list and enter in another column

Jolly good

philb1 · Apr 5th 2016

Re: Copying X amount of names from list and enter in another column

Hi
Paste the code below into the module named Test in the VB editor & have a play. I think it's what you're after
Cheers

Code

Option Explicit


Sub CopyOver()


Dim Ws1 As Worksheet
Dim rPrelims As Range, r1stRound As Range, jColCell As Range
Dim Ws1Lrow As Long
Dim strCell As String
Set Ws1 = ThisWorkbook.Sheets(1)
Set rPrelims = Ws1.Range("B6")
Set r1stRound = Ws1.Range("B8")


'   Find last used row number on Column D Sheet 1
    Ws1Lrow = Ws1.Columns(4).Find(What:="*", LookIn:=xlValues, _
        lookat:=xlPart, SearchOrder:=xlByRows, searchdirection:=xlPrevious, _
        MatchCase:=False, searchformat:=False).Row
        
'   B6 & B8 are not empty
    If Not IsEmpty(rPrelims) And Not IsEmpty(r1stRound) Then
    
'   Copy the number of players in Prelim cell to column H
        Ws1.Range(Ws1.Cells(3, 4), Ws1.Cells(rPrelims.Value + 2, 4)).Copy Ws1.Range("H3")
        
'   Copy the remainder of players to column K
        Ws1.Range(Ws1.Cells(rPrelims.Value + 3, 4), Ws1.Cells(Ws1Lrow, 4)).Copy Ws1.Cells(rPrelims.Value + 3, 11)
        
'   Set the cell in column J which will hold the player number after the last one in column G
        Set jColCell = Ws1.Cells(rPrelims.Value + 3, 10)
        
'   Get the non absolute address of the cell
        strCell = jColCell.Address(False, False)
        
'   Put the place +1 of the last player in column G
        jColCell = Ws1.Cells(rPrelims.Value + 2, 7) + 1
        
'   Put formula in the rest of the range in column J
        Ws1.Range(Ws1.Cells(rPrelims.Value + 4, 10), Ws1.Cells(Ws1Lrow, 10)).Formula = "=(" & strCell & ")+1" ' Equiv =J3+1
    
    End If
    
Exit Sub


End Sub

Display More

philb1 · Mar 31st 2016

Re: macro with formula to be applied to specific columns

Have you got a sample replicating what you're trying to do?
A workbook not a pic etc

philb1 · Mar 30th 2016

Re: Not understanding Error for ExT.Activate

The code you're using forces the macro to override the error, I thought I'd work around using error control, but it's the same difference in the end
The code below is the easy way to delete the contents of columns A & B on the Daily Bidding sheet

Code

Private Sub CommandButton1_Click()


    Dim Db As Worksheet, Dt As Worksheet
    Dim lr As Long


        Set Db = Sheets("Daily Bidding")
        Set Dt = Sheets("Daily Tracking")


        Dt.Activate
        lr = Dt.Cells(Rows.Count, 2).End(xlUp).Row + 1


        Dt.Range("A" & lr).Value = Db.Range("E1").Value 'Date
        Dt.Range("B" & lr).Value = Db.Range("L7").Value '# of Bets
        Dt.Range("C" & lr).Value = Db.Range("M7").Value '# of Calls
        Dt.Range("D" & lr).Value = Db.Range("N7").Value '# of Puts
        Dt.Range("E" & lr).Value = Db.Range("I8").Value 'Win %
        Dt.Range("F" & lr).Value = Db.Range("I9").Value 'Loss %
        Dt.Range("G" & lr).Value = Db.Range("I10").Value 'Draw %
        Dt.Range("H" & lr).Value = Db.Range("F10").Value 'Made
        Dt.Range("I" & lr).Value = Db.Range("I12").Value 'Lost
        
        


On Error Resume Next
    Dt.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = "Table2"


Db.Range(Db.Cells(2, 1), Db.Cells(Rows.Count, 1).End(xlUp)).ClearContents
Db.Range(Db.Cells(2, 2), Db.Cells(Rows.Count, 2).End(xlUp)).ClearContents


End Sub

Display More

philb1 · Mar 30th 2016

Re: Not understanding Error for ExT.Activate

Try this

Code

Option Explicit


Private Sub CommandButton1_Click()
Dim Db As Worksheet, Dt As Worksheet
Dim lr As Long, x As Long
Dim Tbl As ListObject
Dim TableName As String
Set Db = Sheets("Daily Bidding")
Set Dt = Sheets("Daily Tracking")
TableName = "Table2" ' Call it what you like here
x = 0 ' Make sure it's zeroed before we start
lr = Dt.Cells(Rows.Count, 2).End(xlUp).Row + 1


Dt.Range("A" & lr).Value = Db.Range("E1").Value 'Date
Dt.Range("B" & lr).Value = Db.Range("L7").Value '# of Bets
Dt.Range("C" & lr).Value = Db.Range("M7").Value '# of Calls
Dt.Range("D" & lr).Value = Db.Range("N7").Value '# of Puts
Dt.Range("E" & lr).Value = Db.Range("I8").Value 'Win %
Dt.Range("F" & lr).Value = Db.Range("I9").Value 'Loss %
Dt.Range("G" & lr).Value = Db.Range("I10").Value 'Draw %
Dt.Range("H" & lr).Value = Db.Range("F10").Value 'Made
Dt.Range("I" & lr).Value = Db.Range("I12").Value 'Lost


'   You can't place a table on top of a table so we
'   test if the table already exists on Sheet2
For Each Tbl In Dt.ListObjects
    If Tbl.Name = TableName Then x = x + 1
Next Tbl


'   If the table doesn't exist then create it
If x = 0 Then
    Dt.ListObjects.Add(xlSrcRange, Dt.Range(Dt.Cells(1, 1), Dt.Cells(lr, 9)), xlYes).Name = TableName
Else: End If


Exit Sub
End Sub

Display More

philb1 · Mar 29th 2016

Re: Not understanding Error for ExT.Activate

Try changing ExT to Dt on every line that has it. You will also have the same issue with MEx

philb1 · Mar 29th 2016

Re: macro with formula to be applied to specific columns

Hi
Paste the code below into a module & see if it's what you're after. If I can I'll attach a workbook, if not it'll be a dropbox link
It put the formulas in columns M & R then deletes the contents of L & U
If it's the wrong way round you can change the code to suit or I'll do it in the morning if you're stuck

Cheers
Phil

Code

Option Explicit


Sub FiveDigit()


Dim Ws As Worksheet
Dim Lrange As Range, Mrange As Range, Urange As Range, Rrange As Range
Dim LrowL As Long, LrowU As Long
Dim MrangeFormula As String, RrangeFormula As String
Set Ws = ThisWorkbook.ActiveSheet
MrangeFormula = "=CONCATENATE(REPT(0,5-LEN(L2)),L2)"
RrangeFormula = "=CONCATENATE(REPT(0,5-LEN(U2)),U2)"


'   Find bottom row number in column (L)
    LrowL = Ws.Columns(12).Find(What:="*", LookIn:=xlValues, _
        lookat:=xlPart, SearchOrder:=xlByRows, searchdirection:=xlPrevious, _
        MatchCase:=False, searchformat:=False).Row


'   Find bottom row number in column (U)
    LrowU = Ws.Columns(21).Find(What:="*", LookIn:=xlValues, _
        lookat:=xlPart, SearchOrder:=xlByRows, searchdirection:=xlPrevious, _
        MatchCase:=False, searchformat:=False).Row


Set Lrange = Ws.Range(Ws.Cells(2, 12), Ws.Cells(LrowL, 12))
Set Mrange = Ws.Range(Ws.Cells(2, 13), Ws.Cells(LrowL, 13))
Set Urange = Ws.Range(Ws.Cells(2, 21), Ws.Cells(LrowU, 21))
Set Rrange = Ws.Range(Ws.Cells(2, 18), Ws.Cells(LrowU, 18))


With Mrange
    .NumberFormat = "00000"
    .Formula = MrangeFormula
    .Value = .Value
End With


With Rrange
    .NumberFormat = "00000"
    .Formula = RrangeFormula
    .Value = .Value
End With


Lrange.Clear
Urange.Clear


Exit Sub


End Sub

Display More

philb1 · Mar 27th 2016

Re: Macro to select all tabs that contain "PO" in the tab name

Here's another version
It looks for PO in upper case and there is a blank space before PO

Code

Option Explicit


Sub FindPO()


Dim Ws As Worksheet
Dim Xx As Long
Dim WsName As String, PO As String, strTest As String, strBlank As String
PO = "PO" ' Upper Case
strBlank = " "


For Each Ws In ThisWorkbook.Worksheets


'   If Xx variable is greater than 0, found something
    Xx = InStrRev(Ws.Name, PO, -1, vbTextCompare)
    
    If Xx > 0 Then
    
'   Get the text found
    strTest = Mid(Ws.Name, Xx, 2) ' Variable used for code readability
    
'   Test if the text found is upper case to match the PO variable value
'   and there is a blank space before the text found
        If strTest = PO And Mid(Ws.Name, Xx - 1, 1) = strBlank Then
        
'   Put your code here
                
        End If
        
    End If
    
Next Ws


Exit Sub

Display More

philb1 · Mar 13th 2016

Re: Moving between columns (dynamic range?)

Can you post a sample workbook so I can see where the error happens?

philb1 · Mar 12th 2016

Re: Moving between columns (dynamic range?)

Try the code below
You had a zillion if's when you really needed just one. You also had quotation marks surrounding the values you were entering if the condition was met, doing that changes the number value to text.

Code

Sub TEST22()
   Dim ws As Worksheet
   Set ws = ActiveSheet
Dim iRow As Integer, oRow As Integer, uRow As Integer, i As Integer
iRow = 78
oRow = iRow + 1
uRow = iRow + 1




For i = 39 To 52
    
   If Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0 Then
   ws.Cells(uRow, i).Value = 1
   
   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.00208 Then
   ws.Cells(uRow, i).Value = 2




   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.00417 Then
   ws.Cells(uRow, i).Value = 3
   
   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.00625 Then
   ws.Cells(uRow, i).Value = 4
   
   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.00833 Then
   ws.Cells(uRow, i).Value = 5
   
   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.01042 Then
   ws.Cells(uRow, i).Value = 6
   
   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.0125 Then
   ws.Cells(uRow, i).Value = 7
   
   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.01458 Then
   ws.Cells(uRow, i).Value = 8
   
   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.01667 Then
   ws.Cells(uRow, i).Value = 9
   
   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.01875 Then
   ws.Cells(uRow, i).Value = 10
   
   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.02083 Then
   ws.Cells(uRow, i).Value = 11
   
   ElseIf Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5) = 0.02292 Then
   ws.Cells(uRow, i).Value = 12
   
   ElseIf Round(Round(((ws.Cells(oRow, i).Value - ws.Cells(iRow, i).Value) + (ws.Cells(oRow, i).Value < ws.Cells(iRow, i).Value)) / 2400, 5), 5) = 0.04167 Then
   ws.Cells(uRow, i).Value = 13
   Else
   ws.Cells(uRow, i).Value = 13
   End If
   
Next i
End Sub

Display More