+ Reply to Thread
Results 1 to 4 of 4

Hmm my code seems to be playing up, any ideas...

Hybrid View

  1. #1
    Registered User
    Join Date
    04-18-2024
    Location
    England
    MS-Off Ver
    365
    Posts
    2

    Question Hmm my code seems to be playing up, any ideas...

    So basically the code below is to help me automate a repetitive task.

    However for some reason the only part not working as it should is the function where it changes K column from TRUE/FALSE to 1/0 accordingly...any ideas.. Thanks

    Sub AutomateReporting()
        Dim ws As Worksheet
        Dim LastRowA As Long, LastRowK As Long, LastRowF As Long
        Dim rng As Range, cell As Range
        Dim destSheet As Worksheet
        Dim sheetOrder() As String
        Dim i As Long, j As Long
        
        ' Define the worksheet to work with
        Set ws = ThisWorkbook.Sheets("sheet1") ' Change "sheet1" to your sheet's name
        
        ' Turn off screen updating to improve performance
        Application.ScreenUpdating = False
        
        ' Clear any existing filters
        ws.AutoFilterMode = False
        
        ' Find the last row with data in column A, K, and F
        LastRowA = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        LastRowK = ws.Cells(ws.Rows.Count, 11).End(xlUp).Row
        LastRowF = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row
        
        ' Filter column A to find entries starting with 'AA'
        ws.Range("A2:A" & LastRowA).AutoFilter Field:=1, Criteria1:="AA*", Operator:=xlFilterValues
        
        ' Store the range of visible rows with data excluding the header
        On Error Resume Next ' In case no visible cells to delete
        Set rng = ws.Range("A2:A" & LastRowA).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' Delete visible rows containing 'AA' in column A
        If Not rng Is Nothing Then
            rng.EntireRow.Delete
        End If
        
        ' Find the new last row with data in column A after deleting filtered rows
        LastRowA = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        
        ' Filter column K to find 'New'
        ws.AutoFilterMode = False
        ws.Range("K1:K" & LastRowK).AutoFilter Field:=1, Criteria1:="New"
        
        ' Find the last row with data in column K after filtering for 'New'
        LastRowK = ws.Cells(ws.Rows.Count, 11).End(xlUp).Row
        
        ' Convert TRUE to 1 and FALSE to 0 in column K
        For Each cell In ws.Range("K2:K" & LastRowK)
            If cell.Value = "TRUE" Then
                cell.Value = "1"
            ElseIf cell.Value = "FALSE" Then
                cell.Value = "0"
            End If
        Next cell
        
        ' Filter column F to find the unique values
        Dim uniqueValues() As Variant
        uniqueValues = GetUniqueValues(ws.Range("F2:F" & LastRowF))
        
        ' Define the order of sheets
        ReDim sheetOrder(1 To 8) As String
        sheetOrder(1) = "New"
        sheetOrder(2) = "Acc"
        sheetOrder(3) = "Canc"
        sheetOrder(4) = "Surv"
        sheetOrder(5) = "Unsch"
        sheetOrder(6) = "Sche"
        sheetOrder(7) = "En"
        sheetOrder(8) = "Comp"
        
        ' Loop through each unique value in column F
        For j = LBound(sheetOrder) To UBound(sheetOrder)
            ' Loop through unique values to find the matching one
            For i = LBound(uniqueValues) To UBound(uniqueValues)
                If StrComp(uniqueValues(i, 1), sheetOrder(j), vbTextCompare) = 0 Then
                    ' Create a new sheet for the current unique value
                    Set destSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    
                    ' Set the sheet name
                    destSheet.Name = SanitizeSheetName(CStr(uniqueValues(i, 1)))
                    
                    ' Filter column F to find rows with the current unique value
                    ws.AutoFilterMode = False
                    ws.Range("F1:F" & LastRowF).AutoFilter Field:=1, Criteria1:=uniqueValues(i, 1)
                    
                    ' Copy visible rows to the new sheet
                    ws.Range("A1:K" & LastRowA).SpecialCells(xlCellTypeVisible).Copy destSheet.Range("A1")
                    
                    ' Clear filter
                    ws.AutoFilterMode = False
                    
                    ' Exit the loop once the sheet is created
                    Exit For
                End If
            Next i
        Next j
        
        ' Turn on screen updating
        Application.ScreenUpdating = True
        
        MsgBox "MR.E", vbInformation
    End Sub
    
    Function GetUniqueValues(rng As Range) As Variant
        Dim dict As Object
        Dim cell As Range
        Dim arr() As Variant
        Dim i As Long
        
        Set dict = CreateObject("Scripting.Dictionary")
        
        For Each cell In rng
            If Not dict.exists(cell.Value) Then
                dict.Add cell.Value, Nothing
            End If
    
    
        Next cell
        
        ReDim arr(1 To dict.Count, 1 To 1)
        i = 1
        
        For Each Key In dict.keys
            arr(i, 1) = Key
            i = i + 1
        Next Key
        
        GetUniqueValues = arr
    End Function
    
    Function SanitizeSheetName(sheetName As String) As String
        Dim invalidChars As String
        Dim i As Integer
        Dim invalidChar As String
        
        ' Define invalid characters
        invalidChars = ":/\?*[]"
        
        ' Replace invalid characters with underscores
        For i = 1 To Len(invalidChars)
            invalidChar = Mid(invalidChars, i, 1)
            sheetName = Replace(sheetName, invalidChar, "_")
        Next i
        
        ' Truncate to maximum allowed length
        If Len(sheetName) > 31 Then
            sheetName = Left(sheetName, 31)
        End If
        
        SanitizeSheetName = sheetName
    End Function
    Last edited by mrebzz; 04-19-2024 at 03:16 PM. Reason: Update

  2. #2
    Forum Guru
    Join Date
    03-02-2006
    Location
    Los Angeles, Ca
    MS-Off Ver
    WinXP/MSO2007;Win10/MSO2016
    Posts
    12,637

    Re: Hmm my code seems to be playing up, any ideas...

    One in quotes (i.e., "1") is a character, not a number. "TRUE" in quotes is a character string typed in manually, not the Boolean result of a formula. I don't know which you are dealing with since there is no sample file
       For Each cell In ws.Range("K2:K" & LastRowK)
                 .Value = IIF(.Value=TRUE,1,0)
       Next cell
    Last edited by protonLeah; 04-19-2024 at 04:02 PM.
    Ben Van Johnson

  3. #3
    Registered User
    Join Date
    04-18-2024
    Location
    England
    MS-Off Ver
    365
    Posts
    2

    Re: Hmm my code seems to be playing up, any ideas...

    Correct

    I am just basically cleaning some excel data.TRUE (text, Capitals) i just want this to be changed to the number 1. again this can be a string .. its irrelevant in this :D haha thanks for all the help

  4. #4
    Forum Expert
    Join Date
    08-17-2007
    Location
    Poland
    Posts
    2,248

    Re: Hmm my code seems to be playing up, any ideas...

    Or, see
        On Error Resume Next
        For Each Cell In ws.Range("K2:K" & LastRowK)
            With Cell
                .Value = -.Value * 1
            End With
        Next Cell
        On Error GoTo 0
    Error handling for text values in a column.

    Or without the loop:
    Range("K2:K" & LastRowK).Value = Application.Evaluate("TRUNC(K2:K" & LastRowK & ")")
    But will convert the text to an error value.

    Artik

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. [SOLVED] Run next lines of code while voice still playing
    By Kelly mort in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 10-02-2019, 08:23 PM
  2. Playing code after a section
    By ukdjaj in forum Word Programming / VBA / Macros
    Replies: 6
    Last Post: 02-06-2014, 06:21 PM
  3. [SOLVED] Like some ideas on improving code on long IF statement used in VBA code please
    By dawatcher in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 05-12-2013, 01:44 PM
  4. Playing Sound file without pausing code
    By beat in forum Excel Programming / VBA / Macros
    Replies: 0
    Last Post: 01-17-2013, 05:48 AM
  5. [SOLVED] playing an alert sound at the end of code running
    By luv2glyd in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 10-07-2012, 11:07 AM
  6. VBA code for playing wav on MAC os
    By matrex in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 06-20-2011, 11:54 AM
  7. Problem with playing sound code
    By EMoe in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 07-05-2005, 08:30 PM

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1