Jump to content
News Ticker
  • Welcome to the Community
  • Use the forum to troubleshoot your Excel & VBA Problems
  • We will be launching a new website soon! www.ExcelWTF.com/Learn ! Join us to learn VBA from the ground up!


Popular Content

Showing content with the highest reputation since 03/26/2017 in all areas

  1. 1 point
    Sorry for the delay - I finally got around to amending the code and running it. I'm delighted to say that the outcome is stunning. It purged a 22-sheet workbook in about 15 seconds. I then ran Ctrl-G / Blanks and was horrified with what I saw. I had regularly been finding cells on the various worksheets that weren't responding as they should, or that formulae were missing from odd cells. Using your code, followed by Ctrl-G, I can now see exactly where the problems are and can resolve them. Brilliant!! That's one beer I owe you! I'm now going to sit here and draft up your next beer-earning exercise. It's convoluted, as you'll eventually see, so it's going to take me a while to very carefully outline what I'm trying to achieve. Probably won't complete it tonight so don't hold your breath. Thanks again for sorting this current issue.
  2. 1 point
    haha I enjoy problem solving with VBA so keep them coming Yes we could do that, but it would need a slight change. The original code looks at the list items top to bottom... but if we start removing items, the counter in our loop will cause the code to break Luckily we can just start at the end of the list and step backwards Private Sub btnTransfer_Click() '//Source: www.ExcelWTF.com '//Purpose: Move Selection from List1 to List2. Deletes item from List1 Dim i As Long For i = (ListBox1.ListCount - 1) To 0 Step -1 If ListBox1.Selected(i) Then ListBox2.AddItem ListBox1.List(i, 0), 0 ListBox1.RemoveItem i End If Next End Sub Hope that helps Caleeco
  3. 1 point
    Hmm, not done that before... but had a crack at it! Assumed your second Listbox is called 'Listbox2' Private Sub btnTransfer_Click() '//Source: www.ExcelWTF.com '//Purpose: Move Selection from List1 to List2. Clears selection each time. Dim i As Long ListBox2.Clear 'Delete this line if you wish to transfer multiple selections For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then ListBox2.AddItem ListBox1.List(i, 0) End If Next End Sub Please try the code above. Also please note the Listbox2.Clear, this will reset the contents each time the button is clicked. Delete that line if that isnt the intended use case Hope that helps Caleeco
  4. 1 point
    Give this a go, place this code in the Userform Codesheet VBEditor > Double Click UserForm1 in the Project Window > Double Click anywhere in the Userform Private Sub UserForm_Initialize() '//Source: www.ExcelWTF.com '//Purpose: Initialise and Sort Listbox from Sheet Dim i As Long, j As Long Dim SortBox As Variant With Sheets("Data") ListBox1.List = .Range("B1", .Range("B1").End(xlDown)).Value End With With ListBox1 For i = 0 To .ListCount - 2 For j = i + 1 To .ListCount - 1 If .List(i) > .List(j) Then SortBox = .List(j) .List(j) = .List(i) .List(i) = SortBox End If Next j Next i End With End Sub Let me know how you get on Caleeco
  5. 1 point
    Hey Hey Thanks! No problemo, see answers below Alphabetic "Data" Just the defaults "Userform1" & "Listbox1" Thank you Z
  6. 1 point
    Hey Ziya, Good to see you back on the forum! Yes, that shouldn't be too difficult. Some questions for you: Is this an alphabetic or numeric sort? What is the sheet name with the data? What are the assigned names for your Userform and Listbox (Check the Properties window in the VBEditor) Let me know Caleeco
  7. 1 point
    Hi David, Glad you liked the CF solution! Yes, with the spreadsheets I build; I always go for simplicity. As much as I enjoy writing code, VBA isn't always the best answer Excel has lots of in-built tools we can take advantage of! CF is very robust, so many things you can use it for! Ok sounds good, let me know if the colours don't change correctly (I did some testing on my sheet which seemed to work). Haha, yes when dealing with big spreadsheets... efficiency savings are key! Glad I could help Caleeco
  8. 1 point
    Hi Caleeco Re the conditional formatting option - of course! Such an elegantly, simple fix. In all my years of Exceling I've never used that aspect of conditional formatting, so I never even considered it. I use conditional formatting regularly, but always for something either date related or formula based. Brilliant! I've applied it to one worksheet so far and it appears to work perfectly. I'll now look for a sheet where I can add some data that will cause the ranking to change, so I can verify that the colours change correctly. I'll get back to you if I have any problem. Given the elegance of that solution I'll skip VBA. I also don't need additional drain on computation resources, I've already got enough on the spreadsheet that gives a noticeable drop in cooling fan speed! Job done - now you can go back to your website. Many thanks David
  9. 1 point
    I apologize, I thought I had responded to this yesterday, everything seems to be working great. I've tested the tool out a few times and it does exactly what I need. All I need to do is tidy up some of my formulas and figure out why the players and their Tm/Bye scramble on each sort. Thanks for your help and thanks for adding the comments to the code!
  10. 1 point
    Hi Ryan, Sorry for the delay, took me some time to type out all the extra comments! Hopefully they should explain most of the code. If you need any further clarification let me know! Please see new file below (the old one had a mistake in the code, and may have deleted data it shouldnt have!) https://ufile.io/pn1sb So i think this new code below should work for you: Code: Sub PlayerDraft() 'Source: www.ExcelWTF.com '// Declare variables Dim shOverall As Worksheet, Sht As Worksheet Dim lrO As Long, lrPos As Long, PlayerRow As Long Dim rPos As Long, colFantPt As Long, colX As Long Dim Player As String, Position As String Set shOverall = Sheets("Overall") Dim Chk As CheckBox Application.ScreenUpdating = False '// Main Code 'Find last used row on the 'Overall' sheet lrO = shOverall.Range("B" & Rows.Count).End(xlUp).Row 'Find out if the check box clicked is on or off (1 or 0) Set Chk = Sheets("Overall").CheckBoxes(Application.Caller) 'If the checkbox clicked is 1 If Chk = 1 Then 'Check the row the Check box is on PlayerRow = Chk.TopLeftCell.Row 'Find Players Name by looking in adjacent column B of that row Player = shOverall.Range("B" & PlayerRow).Value 'Find the players position (RB, WR, QB etc) and create a reference to that sheet Set Sht = Sheets(Range("C" & PlayerRow).Value) With Sht 'Find the last used row of the Position sheet lrPos = Sht.Range("C" & Rows.Count).End(xlUp).Row 'Find the row the Player is on the Position sheet rPos = .Range("C2:C" & lrPos).Find(Player).Row 'On the position sheet, find the column number for the 'FantPt' Column colFantPt = .Rows(1).Find("FantPt").Column 'On the position sheet, find the column number for the 'X-Factor' Column colX = .Rows(1).Find("X-Factor").Column 'Clear the FantPt value for the player on the Position sheet .Cells(rPos, colFantPt).ClearContents 'Clear any exisitng filters .AutoFilter.Sort.SortFields.Clear 'Sort the 'X-Factor' column on the Position sheet .AutoFilter.Sort.SortFields.Add Key:=.Range( _ .Cells(1, colX), .Cells(lrPos, colX)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _ xlSortNormal With .AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .Apply End With End With 'Go back to the 'Overall' Sheet and sort on column G With shOverall .AutoFilter.Sort.SortFields.Clear .AutoFilter.Sort.SortFields.Add Key:= _ Range("G1:G" & lrO), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _ :=xlSortNormal With .AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .Apply End With End With End If Application.ScreenUpdating = True End Sub Bearing in mind that the SETBOX code, only needs to be run once (which I have done on the attached sheet)... so you shouldnt have to do it again. Code: Sub SetBox() 'Source: www.ExcelWTF.com ' This code only needs to be run once ' It will set each checkbox to run the PlayerDraft Macro when clicked Dim chkBx As CheckBox For Each chkBx In Sheets("Overall").CheckBoxes chkBx.OnAction = "PlayerDraft" Next End Sub Let me know if it works on your end, Cheers Caleeco
  11. 1 point
    Hi Cal, I'm back I see you have re-modelled your previous re-model! The new website is looking amazing! Still I see no new emotes hopefully its on your list of thing to add. Got a few more VBA Q's, will post them up soon Z
  12. 1 point
    Hi Ryan, Ok cool, thanks for the clarification. I'll draft some code up for you to test in a moment. Thanks! Caleeco
  13. 1 point
    Hi Ziya, No problem, I'm happy to help! With regard to the alignment , each cell has an INDENT property we can make use of. So towards the bottom of the code please edit this WITH statement: Code: With shLabel.Columns("A:C") .ClearContents .VerticalAlignment = xlVAlignCenter .IndentLevel = 5 End With Change the INDENT LEVEL to suit your requirement. Aha, you're half right there. The variable Label is a string, but it is an ARRAY of strings. As declared at the start, the parenthesis are the clue to knowing its an ARRAY rather than a variable. Code: Dim Label() As String You can think of an array like a table of data, the size of the table can be whatever you like. In this instance, i changed the size of the array to match how many rows of data we had (adjusting -1 to account for the fact the data starts in row 2). Code: lr = shYear.Range("I" & Rows.Count).End(xlUp).Row 'Find the last used rowReDim Label(lr - 1) 'Set the size of the array Each row of an ARRAY is called an ELEMENT. So i created a loop, to fill each ELEMENT with 1 address from your 2017 sheet If you would like a more in depth explanation I would be happy to talk you through it. However, I will be starting a blog on the website very soon to teach people this sort of thing Caleeco
  14. 1 point
    Thanks for the additional information. I have put some code together for you to test! Note: The Option Base 1 statement must appear at the top of your code Code: Option Explicit Option Base 1 Sub CreateLabels() 'Source: www.ExcelWTF.com 'Purpose: To create address labels using data from excel sheet '----- Variables Dim shYear As Worksheet, shLabel As Worksheet Dim lr As Long, i As Long, j As Long, k As Long Dim Label() As String Dim r As Range, RNG As Range '----- Code i = 1 Set shYear = Sheets("2017") 'Change the line below next year if you create a new sheet lr = shYear.Range("I" & Rows.Count).End(xlUp).Row 'Find the last used row ReDim Label(lr - 1) 'Set the size of the array Set RNG = shYear.Range("F2:F" & lr) 'Set the data range to loop through Application.ScreenUpdating = False On Error Resume Next For Each r In RNG 'Collate information in the array If Not IsEmpty(r.Value) Then Label(i) = Label(i) & r.Value & " " 'Title If Not IsEmpty(r.Offset(0, 1).Value) Then Label(i) = Label(i) & r.Offset(0, 1).Value & " " 'Initial If Not IsEmpty(r.Offset(0, 3).Value) Then Label(i) = Label(i) & r.Offset(0, 3).Value & vbCrLf 'Surname If Not IsEmpty(r.Offset(0, 4).Value) Then Label(i) = Label(i) & r.Offset(0, 4).Value & vbCrLf 'Add 1 If Not IsEmpty(r.Offset(0, 5).Value) Then Label(i) = Label(i) & r.Offset(0, 5).Value & vbCrLf 'Add 2 If Not IsEmpty(r.Offset(0, 6).Value) Then Label(i) = Label(i) & r.Offset(0, 6).Value & vbCrLf 'Add 3 If Not IsEmpty(r.Offset(0, 7).Value) Then Label(i) = Label(i) & r.Offset(0, 7).Value & vbCrLf 'Add 4 If Not IsEmpty(r.Offset(0, 8).Value) Then Label(i) = Label(i) & r.Offset(0, 8).Value & vbCrLf 'Add 5 If Not IsEmpty(r.Offset(0, 9).Value) Then Label(i) = Label(i) & r.Offset(0, 9).Value & vbCrLf 'Add 6 If Not IsEmpty(r.Offset(0, 10).Value) Then Label(i) = Label(i) & r.Offset(0, 10).Value 'PostCode 'Debug.Print Label(i) i = i + 1 Next r 'Print the data to the labels sheet Set shLabel = Sheets("Labels") With shLabel.Columns("A:C") .ClearContents .VerticalAlignment = xlVAlignCenter End With j = 1 k = 1 For i = LBound(Label) To UBound(Label) shLabel.Cells(j, k).Value = Label(i) If k = 1 Then k = 3 ElseIf k = 3 Then k = 1 j = j + 1 End If Next Application.ScreenUpdating = True End Sub Let me know how you get on Thanks Caleeco
  15. 1 point
    Hi Reso, Sure thing, that's just a small edit. Add the following snippet before the last line (where the location is printed to the dashboard) Code: If Found = False Then MsgBox "Part Number " & PartNo & " not found in either dataset", vbCritical, "Error" Exit Sub End If Hope that helps Caleeco
  16. 1 point
    Hello, Came over from another well known Excel Forum, Nice website Caleeco! Looks pretty slick. I'll be sure to post my next VBA query over here, should be fairly soon lol, working on some coding at the moment Reso
  17. 1 point
    Hi Reso, Thanks for the additional information. Apologies for the delay in getting back to you, upgrading websites can be very time consuming Give this code a spin and let me know if it works on your end: Code: Sub FindPart() 'Source: www.ExcelWTF.com 'Purpose: To locate part number and list found location '----Variables Dim PartNo As String, Location As String Dim ws As Worksheet, wsDash As Worksheet, wsSAP As Worksheet, wsUser As Worksheet Dim c As Range Dim lr As Long Dim Found As Boolean '----Code Set wsDash = Sheets("Dashboard") Set wsSAP = Sheets("SAP Data") Set wsUser = Sheets("User Input") 'Set the PartNo to search for PartNo = wsDash.Range("A4") 'Search for the Part Number, setting a dynamic range in column C of SAP DATA lr = wsSAP.Range("C" & Rows.Count).End(xlUp).Row Set c = wsSAP.Range("C2:C" & lr).Find(PartNo, , xlValues, xlWhole, xlByRows, , True) If Not c Is Nothing Then Location = wsSAP.Name & " - " & c.Address(0, 0) Found = True End If 'Search for the Part Number, setting a dynamic range in column C of User Input lr = wsUser.Range("C" & Rows.Count).End(xlUp).Row Set c = wsUser.Range("C2:C" & lr).Find(PartNo, , xlValues, xlWhole, xlByRows, , True) If Not c Is Nothing Then If Found = True Then MsgBox "Part Number " & PartNo & " was found on both sheets. Exiting macro...", vbCritical, "Error" Else Location = wsUser.Name & " - " & c.Address(0, 0) End If End If 'Print location to Dashboard sheet wsDash.Range("D4").Value = Location End Sub Thanks Caleeco
  18. 1 point
    The new website looks great, certainly an upgrade! More emoticons would be nice I could do with some more confused ones... as that's my expression most of the time when using VBA Z
  19. 1 point
    Website looks awesome! Clean design, the logos are awesome! Not much to add, looks like your list of scheduled improvements should cover it
  20. 1 point
    hehe yes, thankfully each batch size of data is the same so we can avoid having a SELECT CASE or IF statement Sorry, my mistake! Totally forgot about the coloured cell. I've added a few more lines of code in the main IF statement to cover that. Hopefully light blue fits your colour scheme. Code: Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Source: www.ExcelWTF.com 'Purpose: Auto-hide columns based on cell selection '---- Variables Dim r As Long '---- Code 'Exit Sub if more than one cell is selected or data is deleted If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub 'If selection is in the 'Product Range' If Not Intersect(Target, Range("A2:A11")) Is Nothing Then r = ActiveCell.Row 'Determine the current row number ActiveSheet.Range("A2:A11").Interior.ColorIndex = 0 ' Clear Colours ActiveSheet.Range("A" & r).Interior.ColorIndex = 37 'Colour the correct cell Columns("B:AY").EntireColumn.Hidden = True 'Hide all columns 'The code below works out the Starting column number for each batch of data If r > 2 Then r = 2 + (r - 2) * 5 'Unhide the data in column r and the next 4 columns Range(Columns(r), Columns(r + 4)).EntireColumn.Hidden = False End If End Sub Thanks, Caleeco
  21. 1 point
    Wait... what!? LOL I was expecting some sort of 10 level IF Statement, but that equation to find the starting column is genius... i wouldn't have thought of that! Code works great! However, the selected cell doesnt appear to turn blue when I choose a product. Do I need to add conditional formatting or something? Z
  22. 1 point
    Hi Guys Nice site Caleeco I am looking for a VBA to copy the values from one workbook to another based on the column headings, sample data attached. The "Conversion_Sheet" has the data that I want to copy to the "Import_Sheet". The "Conversion_Sheet" has to contain the VBA code as the "Import_Sheet" has to be saved as xls to be imported. The column headings are constantly changing and there could be anything between 2 columns to 200. Additionally there could be 1000s of rows. Any help as always will be a great help. Thanks Dougie Conversion_Sheet.xlsm Import_Sheet.xlsx
  23. 1 point
    Hi Dougie! Welcome to the forum, I'm glad you decided to sign up Thank you, I'm still making some design improvements/modification but I'm nearly there! I will take a look at the sample sheets you have provided and get back to you with some code to try Many Thanks Caleeco
  24. 1 point
    Hi Geeperz, Apologies, I dont know why it stripped out that syntax! New board...got a few things to fix! I just tested the code below, and it works on my end. The Code you uploaded wasnt working as the loop statement should be Loop While rFound.Address FirstAddress Working code: Sub TransposeData2() Application.ScreenUpdating = False Dim rFound As Range Dim FirstAddress As String Dim lC As Long 'Count variable for the rows lC = 0 Worksheets("Combine Sheet").Activate With Worksheets("Combine Sheet").Columns("C:C") Set rFound = .Find(What:="Make", After:=Range("C" & Rows.Count), LookIn:=xlValues, _ lookat:=xlWhole, Searchorder:=xlByRows, Searchdirection:=xlNext, MatchCase:=False) If Not rFound Is Nothing Then 'Value has been found FirstAddress = rFound.Address lC = Worksheets("Extract").Range("A" & Rows.Count).End(xlUp).Row Do rFound.Select 'Add post processing If rFound.Offset(0, 1) = vbNullString Then 'There is some data missing Range(rFound.Offset(1, 1), rFound.Offset(1, 1).End(xlDown)).Copy Worksheets("Extract").Range("A" & lC).Offset(1, 1).PasteSpecial Paste:=xlValues, Transpose:=True lC = lC + 1 Else Range(rFound.Offset(0, 1), rFound.Offset(0, 1).End(xlDown)).Copy Worksheets("Extract").Range("A" & lC).Offset(1, 0).PasteSpecial Paste:=xlValues, Transpose:=True lC = lC + 1 End If Set rFound = .FindNext(After:=rFound) Loop While rFound.Address FirstAddress Else 'Value has NOT been found Exit Sub End If End With Application.CutCopyMode = False Application.ScreenUpdating = False End Sub Thanks for your patience Regards Caleeco
  25. 1 point
    No Problem, I'll leave it with you. Give me a shout if it needs any tweaks when you do get it tested. Many Thanks Caleeco