Posts by jaslake

jaslake · Sep 29th 2015

Re: vlookup, index or match for aligning data in worksheets?

Hi Pacer

Try this...

Code

Option Explicit
Sub Match()
   Dim ws           As Worksheet
   Dim ws1          As Worksheet
   Dim LR           As Long
   Dim Rng1         As Range
   Dim cel          As Range
   Set ws = Sheets("employee")
   Set ws1 = Sheets("main")
   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      For Each cel In .Range(.Cells(2, "C"), .Cells(LR, "C"))
         With ws1.Columns("D:D")
            Set Rng1 = .Find(What:=cel.Value, _
                             After:=.Cells(.Cells.Count), _
                             LookIn:=xlValues, _
                             LookAt:=xlWhole, _
                             SearchOrder:=xlByRows, _
                             SearchDirection:=xlNext, _
                             MatchCase:=False)
            If Not Rng1 Is Nothing Then
               ws1.Cells(Rng1.Row, "G") = ws.Cells(cel.Row, "B").Value
            End If
         End With
      Next cel
   End With
End Sub

Display More

jaslake · Sep 26th 2015

Re: Macro - Resize table length by variable

Hi jhallcb

This Code in the attached uses the "Always Insert" construct such that you don't need a variable to Resize. The Code is based on your Sample Data...see if you can adapt to your needs. Need help, let me know.

Code

Option Explicit
Sub Add_Table_Row()
   Dim ws           As Worksheet
   Dim lo1          As ListObject
   Dim lo2          As ListObject
   Dim x            As Long
   Dim y            As Long
   Dim z            As Long
   Dim Rng          As Range
   Set ws = Sheets("Sheet1")
   Set lo1 = ws.ListObjects("Table2")
   Set lo2 = ws.ListObjects("Table3")
   With lo1
      Set Rng = .ListColumns(2).Range
      x = Rng.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row - 1
   End With
   With lo2
      Set Rng = .ListColumns(1).Range
      y = Rng.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row - 1
      If x = y Then
         'No new Data Added
         Exit Sub
      End If
      z = .ListRows.Count + 2
      Application.EnableEvents = False
      ActiveSheet.Unprotect
      .ListRows.Add AlwaysInsert:=True
      ActiveSheet.Protect
      Application.EnableEvents = True
   End With
End Sub

Display More

jaslake · Sep 21st 2015

Re: Finding previous blank cell

Hi sassy2

You don't indicate how Rows get added and you didn't include the Code you referenced.

That aside, it seems to me you may not need Code for this depending on how the Rows are being added...Formulas may well do it.

See attached...

jaslake · Sep 16th 2015

Re: Match two columns amount with different account numbers

You're welcome...glad I could help.

jaslake · Sep 15th 2015

Re: Match two columns amount with different account numbers

Hi Jintony

Let's try one more time...

Code

Option Explicit
Private Sub CommandButton1_Click()
   Dim LR           As Long
   Dim cel          As Range
   Dim c            As Range
   Dim ws           As Worksheet
   Dim firstaddress As String
   Set ws = Sheets("Raw data")
   With ws
      LR = .Range("A" & .Rows.Count).End(xlUp).Row
      .Cells(LR + 1, "A").EntireRow.Delete
      .Range(.Cells(2, "G"), .Cells(LR, "J")).ClearContents
      For Each cel In .Range(.Cells(2, "E"), .Cells(LR, "E"))
         If Not cel.Value = "" Then
            '         If cel.Value = 30 Then Stop
            With .Range("F:F")
               Set c = .Find(cel.Value, LookIn:=xlFormulas, lookat:=xlWhole)
               If Not c Is Nothing Then
                  firstaddress = c.Address
                  Do
                     If cel.Offset(0, -4).Value <> c.Offset(0, -5) And _
                        c.Offset(0, 2).Value = "" And cel.Offset(0, 2).Value = "" Then
                        cel.Offset(0, 2).Value = cel.Value
                        c.Offset(0, 2).Value = c.Value
                        cel.Offset(0, 4).Value = c.Address
                        c.Offset(0, 4).Value = cel.Address
                     End If
                     Set c = .FindNext(c)
                  Loop While Not c Is Nothing And c.Address <> firstaddress
               End If
            End With
         End If
      Next cel
      .Cells(LR + 1, "E").Formula = "=Sum(E2:E" & LR & ")"
      .Range("E" & LR + 1).AutoFill Destination:=.Range("E" & LR + 1 & ":H" & LR + 1), Type:=xlFillDefault
   End With
End Sub

Display More

jaslake · Sep 13th 2015

Re: Match two columns amount with different account numbers

Hi Jintony

This Code is in the attached. The Code will not Match the two 2700.00 records at Rows 74 and 75 due to the Order of Processing of the Records and this Rule.

Quote

E and F are equal (Match), but do NOT the same account number (Column A)

Code

Option Explicit
Private Sub CommandButton1_Click()
   Dim LR           As Long
   Dim cel          As Range
   Dim c            As Range
   Dim ws           As Worksheet
   Dim firstaddress As String
   Set ws = Sheets("Raw data")
   With ws
      LR = .Range("A" & .Rows.Count).End(xlUp).Row
      .Cells(LR + 1, "A").EntireRow.Delete
      .Range(.Cells(2, "G"), .Cells(LR, "H")).ClearContents
      For Each cel In .Range(.Cells(2, "E"), .Cells(LR, "E"))
         If Not cel.Value = "" Then
            With .Range("F:F")
               Set c = .Find(cel.Value, LookIn:=xlFormulas)
               If Not c Is Nothing Then
                  firstaddress = c.Address
                  Do
                     If cel.Offset(0, -4).Value <> c.Offset(0, -5) And _
                        cel.Offset(0, -3).Value = c.Offset(0, -4).Value And _
                        c.Offset(0, 2).Value = "" And cel.Offset(0, 2).Value = "" Then
                        cel.Offset(0, 2).Value = cel.Value
                        c.Offset(0, 2).Value = c.Value
                     End If
                     Set c = .FindNext(c)
                  Loop While Not c Is Nothing And c.Address <> firstaddress
               End If
            End With
         End If
      Next cel
      .Cells(LR + 1, "E").Formula = "=Sum(E2:E" & LR & ")"
      .Range("E" & LR + 1).AutoFill Destination:=.Range("E" & LR + 1 & ":H" & LR + 1), Type:=xlFillDefault
   End With
End Sub

Display More

jaslake · Sep 11th 2015

Re: Copy range, paste in outlook mail and send e-mail

Hi SAS83

This Code will delete all Controls (Form Controls, ActiveX Controls, Pictures, etc.) on the Worksheet.

The first Line of Code says that if there is an error because no Controls exist then skip the next two lines of Code.
The second line of Code says that if Controls do exist and they're hidden, make them visible.
The third line of Code says delete all of them.
The fourth line of Code is the bail out line for the first line of Code.

Code

On Error Resume Next
          .DrawingObjects.Visible = True
          .DrawingObjects.Delete 
        On Error Goto

jaslake · Jun 23rd 2015

Re: Data Query based on Button Clicks VBA help required

Hi kumarma

Add this Code to your button on Sheet1

Code

Sub All_Employees_Sheet1()
   Dim ws           As Worksheet
   Dim ws1          As Worksheet
   Dim LR           As Long
   Dim LC           As Long
   Dim LR1          As Long
   Set ws = Sheets("Emp Database")
   Set ws1 = Sheets("Decision support tool")
   Application.ScreenUpdating = False
   With ws1
      .AutoFilterMode = False
      LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
      If LR1 = 35 Then LR1 = 36
      .Range(.Cells(36, "B"), .Cells(LR1, "O")).ClearContents
      .Range(.Cells(36, "Q"), .Cells(LR1, "V")).ClearContents
      .Range(.Cells(36, "Y"), .Cells(LR1, "AB")).ClearContents
   End With
   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                       SearchDirection:=xlPrevious).Column
      .Range(.Cells(36, "B"), .Cells(LR, "O")).SpecialCells(xlCellTypeVisible).Copy
      ws1.Range("B36").PasteSpecial
      .Range(.Cells(36, "Q"), .Cells(LR, "V")).SpecialCells(xlCellTypeVisible).Copy
      ws1.Range("Q36").PasteSpecial
      .Range(.Cells(36, "Y"), .Cells(LR, "AB")).SpecialCells(xlCellTypeVisible).Copy
      ws1.Range("Y36").PasteSpecial
      Application.CutCopyMode = False
   End With
   Application.ScreenUpdating = True
End Sub

Display More

Add this Code to your button on Sheet2

Code

Sub All_Employees_Sheet2()
   Dim ws           As Worksheet
   Dim ws1          As Worksheet
   Dim LR           As Long
   Dim LC           As Long
   Dim LR1          As Long
   Dim LC1          As Long
   Set ws = Sheets("Emp Database")
   Set ws1 = Sheets("9-Box distribution")
   Application.ScreenUpdating = False
   With ws1
      .AutoFilterMode = False
      LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
      LC1 = .Cells(35, .Columns.Count).End(xlToLeft).Column
      If LR1 = 35 Then LR1 = 36
      .Range(.Cells(36, "B"), .Cells(LR1, LC1)).ClearContents
   End With
   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                       SearchDirection:=xlPrevious).Column
      .Range(.Cells(36, "B"), .Cells(LR, LC)).SpecialCells(xlCellTypeVisible).Copy
      ws1.Range("B36").PasteSpecial (xlPasteValues)
      Application.CutCopyMode = False
   End With
   Application.ScreenUpdating = True
End Sub

Display More

To protect the project:
Alt + F11
Select Tools
Select VBAProject Properties
Select Protection

jaslake · Jun 21st 2015

Re: Consolidation (Sum up all values from multiple worksheets to one worksheet)

Hi paperlurve

This Forum (and most others) discourage Cross Posting. If you must, please inform us you've done so.

http://www.excelguru.ca/forums…rksheets-to-one-worksheet)

http://www.ozgrid.com/forum/showthread.php?t=195360

Crossposting etiquette is explained here http://www.excelguru.ca/content.php?184

jaslake · Jun 19th 2015

Re: Data Query based on Button Clicks VBA help required

Hi kumarma

I have no idea what you're asking for. What's this refer to...

Quote

Box 9, Box 8, Box 7 and so on till Box 1

You might look at the Sub Total Function...

Here's a link http://www.techonthenet.com/excel/formulas/subtotal.php

Function number is the number 1 to 11 (includes hidden values) or 101 to 111 (ignores hidden values) that specifies which function to use in calculating subtotals within a list.

1 or 101 AVERAGE
2 or 102 COUNT
3 or 103 COUNTA
4 or 104 MAX
5 or 105 MIN
6 or 106 PRODUCT
7 or 107 STDEV
8 or 108 STDEVP
9 or 109 SUM
10 or 110 VAR
11 or 111 VARP

If you will post your File with a clear description of this new requirement I'll be glad to look at it. Any additional requirements should be in a new Thread.

jaslake · Jun 18th 2015

Re: Data Query based on Button Clicks VBA help required

Hi kumarma

This is done..

Quote

Also please help in 9-Box distribution ws code as well.

So, in reality, you want Columns B to Column AB (***Excluding Column P, W, X as it contains formulas) populated with data from Employee Database. There will be information in Columns O to AB (if it exists), or not (if it does not exist).

Try the Code in the attached...let me know of issues

jaslake · Jun 18th 2015

Re: Copy/paste columns into another sheet if headers match

Glad you got it sorted...

jaslake · Jun 18th 2015

Re: Copy/paste columns into another sheet if headers match

Hi opbeland

Try this Code in a general Module

Code

Option Explicit
Sub LookAtColumnHeaders()
   Dim SrcWS        As Worksheet
   Dim TgtWS        As Worksheet
   Dim SrcColHdrs   As Range
   Dim srcCel       As Range
   Dim TgtColHdrs   As Range
   Dim srcLC        As Long
   Dim tgtLC        As Long
   Dim chgCnt       As Long
   Dim newCnt       As Long
   Dim c            As Range
   chgCnt = 0
   newCnt = 0
   Set SrcWS = Sheets("WSnew")
   Set TgtWS = Sheets("WSmaster")
   With SrcWS
      srcLC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious).Column
      Set SrcColHdrs = .Range(.Cells(1, "B"), .Cells(1, srcLC))
   End With
   With TgtWS
      tgtLC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious).Column
      Set TgtColHdrs = .Range(.Cells(1, "B"), .Cells(1, tgtLC))
   End With
   Application.ScreenUpdating = False
   With SrcWS
      For Each srcCel In SrcColHdrs
         Set c = TgtColHdrs.Find(srcCel.Value, , xlValues, xlWhole, xlByRows, xlNext, False)
         If Not c Is Nothing Then
            chgCnt = chgCnt + 1
            .Columns(srcCel.Column).Copy
            TgtWS.Cells(1, c.Column).PasteSpecial
         Else
            newCnt = newCnt + 1
            .Columns(srcCel.Column).Copy
            TgtWS.Cells(1, tgtLC).PasteSpecial
            tgtLC = tgtLC + 1
         End If
      Next srcCel
      Application.CutCopyMode = False
      Application.ScreenUpdating = True
      MsgBox chgCnt & " Columns were updated"
      MsgBox newCnt & " Columns were added"
   End With
End Sub

Display More

jaslake · Jun 17th 2015

Re: Data Query based on Button Clicks VBA help required

Hi kumarma

When Decision Support Tool is populated with the Run Command from Employee Data Base you indicate to populate only Columns B to N.

Quote

In Decision support tool WS, I want the code to pull the information from the Employee Database WS based on the Tower and Team Drop Downs (F23 & F24) selected and update it from Column B to Column N

What if Data exists in Columns O through AB of Employee Database? Should it NOT be brought over to Decision Support Tool? If it's NOT brought over and the Manager does NOT populate a previously populated Field, the previous Data will be lost...or...am I missing something?

Quote

Managers will update the information from Column O to Column AB (****Excluding the Column P, W, X --> as these columns contain formulas and they should not chage). Once they have updated the information and click on Update Date button i want the code to paste the values of that particular resource (Tower/Team selected in drop down) Paste Special --> Values From Column O to Column AB in Decision suppor tool WS to Employee Database

Only you know how you intend to use this.

Edit: Currently the Update Button replaces the ENTIRE Row in Employee Database with the Row of Data from Decision Support Tool.

Code

Set c = rng.Find(cel.Value, , xlValues, xlWhole, xlByRows, xlNext, False)
      ws1.Range(ws1.Cells(cel.Row, "B"), ws1.Cells(cel.Row, LC1)).Copy
      ws.Cells(c.Row, "B").PasteSpecial (xlPasteValues)

jaslake · Jun 17th 2015

Re: Data Query based on Button Clicks VBA help required

Hi kumarma

Never mind...I see it...

jaslake · Jun 17th 2015

Re: Data Query based on Button Clicks VBA help required

Hi kumarma

I'll need to study it a bit...get back to you.

jaslake · Jun 2nd 2015

Re: Data Query based on Button Clicks VBA help required

Hi kumarma

This Code in the attached appears to do as you require. I've assumed NO to this

Quote

Will you ever have more than 9 Groups?

The Edit Mode Button has not been programed as I don't know it's intended purpose.

Code

Option Explicit
Sub Clear_Data()
   Dim ws1          As Worksheet
   Dim LR1          As Long
   Dim LC1          As Long
   Set ws1 = Sheets("Decision support tool")
   With ws1
      LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
      LC1 = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious).Column
      If LR1 = 35 Then LR1 = 36
      .Range(.Cells(36, "B"), .Cells(LR1, LC1)).ClearContents
   End With
End Sub


Sub Run_Me()
   Dim ws           As Worksheet
   Dim ws1          As Worksheet
   Dim rng          As Range
   Dim LR           As Long
   Dim LC           As Long
   Dim LR1          As Long
   Dim LC1          As Long
   Dim x            As Long
   Set ws = Sheets("Emp Database")
   Set ws1 = Sheets("Decision support tool")
   With ws1
      LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
      LC1 = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious).Column
      If LR1 = 35 Then LR1 = 36
      .Range(.Cells(36, "B"), .Cells(LR1, LC1)).ClearContents
   End With
   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                       SearchDirection:=xlPrevious).Column
      .Range(.Cells(35, "B"), .Cells(LR, LC)).AutoFilter field:=4, Criteria1:=ws1.Range("F23").Value
      .Range(.Cells(35, "B"), .Cells(LR, LC)).AutoFilter field:=5, Criteria1:=ws1.Range("F24").Value
      Set rng = .AutoFilter.Range
      x = rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
      If x >= 1 Then
         .Range(.Cells(36, "B"), .Cells(LR, LC)).SpecialCells(xlCellTypeVisible).Copy
         ws1.Range("B36").PasteSpecial
         Application.CutCopyMode = False
      Else
         MsgBox "No Records Found"
      End If
      .AutoFilterMode = False
   End With
End Sub


Sub DoTheWork()
   Dim myBtn        As Button
   Dim myGroup      As String
   Dim ws           As Worksheet
   Dim LC           As Long
   Dim LR           As Long
   Set myBtn = Sheets("Decision support tool").Buttons(Application.Caller)
   myGroup = Right(myBtn.Caption, 1)
   Set ws = Sheets("Decision support tool")
   Application.ScreenUpdating = False
   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                       SearchDirection:=xlPrevious).Column
      If Not .AutoFilterMode Then
         .Range(.Cells(35, "B"), .Cells(LR, LC)).AutoFilter
      End If
      .Range(.Cells(35, "B"), .Cells(LR, LC)).AutoFilter field:=8, Criteria1:=myGroup
   End With
   Application.ScreenUpdating = True
End Sub


Sub Show_All()
   On Error Resume Next
   Sheets("Decision support tool").ShowAllData
   On Error GoTo 0
End Sub


Sub Update()
   Dim ws           As Worksheet
   Dim ws1          As Worksheet
   Dim rng          As Range
   Dim rng1         As Range
   Dim cel          As Range
   Dim c            As Range
   Dim LR           As Long
   Dim LR1          As Long
   Dim LC1          As Long
   Set ws = Sheets("Emp Database")
   Set ws1 = Sheets("Decision support tool")
   With ws1
      LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
      LC1 = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious).Column
      Set rng1 = ws1.Range(ws1.Cells(36, "B"), ws1.Cells(LR1, "B")).SpecialCells(xlCellTypeVisible)
   End With
   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      Set rng = ws.Range(ws.Cells(36, "B"), ws.Cells(LR, "B"))
   End With
   Application.ScreenUpdating = False
   For Each cel In rng1
      Set c = rng.Find(cel.Value, , xlValues, xlWhole, xlByRows, xlNext, False)
      ws1.Range(ws1.Cells(cel.Row, "B"), ws1.Cells(cel.Row, LC1)).Copy
      ws.Cells(c.Row, "B").PasteSpecial (xlPasteValues)
   Next cel
   Application.ScreenUpdating = True
End Sub

Display More

jaslake · Jun 2nd 2015

Re: Data Query based on Button Clicks VBA help required

Hi kumarma

Will you ever have more than 9 Groups?

What's the intended purpose of the Edit Mode Button?

jaslake · May 12th 2015

Re: filter multi column and result will show in next sheet

You're welcome...glad I could help.

jaslake · May 10th 2015

Re: IF Match Three Criteria Then Copy Entire Row To 3d

Hi Dave

I think KjBox has it surrounded using Concatenation...