Detect a different cell and split the data to another sheet

excelthong

Active Member
Joined
Jul 13, 2006
Messages
295
Hi Forumate

thank you for your help and hope some expert can guide me here.

I have a list of data from A1 to AE3548
however the algorithm is simple, there is a time difference in column C,
which mean
C1 :C14 = 2:20 and
C14:C20 = 2:30,
C21:C27 = 3:00 etc
column B is date

may i know how can i copy the data and split the sheet like
when C14 and C15 is different, copy A15to AE15 to a new sheet
when C20 and C21 is different, trigger and copy A20 to AE20 to new sheet?
and use the date in column B to name the sheet in the order like 200327-1 etc?

thank you for the helps
thong
 

Some videos you may like

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.

CephasOz

New Member
Joined
Feb 18, 2020
Messages
41
Office Version
365, 2016
Platform
Windows
Hi excelthong. Try this:

VBA Code:
Sub SplitData()
    Const clngDateCol As Long = 2
    Const clngTimeCol As Long = 3
    Dim rngLastCell As Range
    Dim lngRow As Long
    Dim lngRowBgn As Long
    Dim datPrevDate As Date
    Dim strPrevTime As String
    Dim wksNew As Worksheet
    '
    With ActiveSheet
        lngRowBgn = 1
        datPrevDate = .Cells(lngRowBgn, clngDateCol).Value
        strPrevTime = .Cells(lngRowBgn, clngTimeCol).Text
        Set rngLastCell = LastUsedCell(ActiveSheet)
        For lngRow = 2 To rngLastCell.Row + 1
            If ((.Cells(lngRow, clngDateCol).Value <> datPrevDate) Or (.Cells(lngRow, clngTimeCol).Text <> strPrevTime)) Then
                Set wksNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
                wksNew.Name = SheetNameFromDate(datPrevDate)
                .Range(.Cells(lngRowBgn, 1), .Cells(lngRow - 1, rngLastCell.Column)).Copy _
                    Destination:=wksNew.Cells(1, 1)
                lngRowBgn = lngRow
                datPrevDate = .Cells(lngRowBgn, clngDateCol).Value
                strPrevTime = .Cells(lngRowBgn, clngTimeCol).Text
            End If
        Next
        .Activate
    End With
Housekeeping:
    Set rngLastCell = Nothing
    Set wksNew = Nothing
    Exit Sub
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Sub

' Create a worksheet name from a date.
Function SheetNameFromDate(ByVal datToUse As Date) As String
    Dim intCntr As Integer
    Dim strPrefix As String
    strPrefix = Format(datToUse, "yymmdd-")
    intCntr = 1
    Do While WorksheetExists(strPrefix & Format(intCntr))
        intCntr = intCntr + 1
    Loop
    SheetNameFromDate = strPrefix & Format(intCntr)
End Function

' Check if a particular sheet exists within ThisWorkbook.
Function WorksheetExists(ByVal strWks As String) As Boolean
    WorksheetExists = False
    On Error GoTo Err_Exit
    WorksheetExists = (ThisWorkbook.Worksheets(strWks).Name <> vbNullString)
Housekeeping:
    Exit Function
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Function

'Find the last used cell in a worksheet.
Function LastUsedCell(wksToUse As Worksheet) As Range
    Dim lngRow As Long
    Dim lngCol As Long
    Dim rngFound As Range
    '
    Set LastUsedCell = wksToUse.Cells(1, 1)
    On Error GoTo Err_Exit
    '
    Set rngFound = wksToUse.Cells.Find(What:="*", _
        LookIn:=xlFormulas, _
        LookAt:=xlPart, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False)
    If (Not (rngFound Is Nothing)) Then
        lngRow = rngFound.Row
        Set rngFound = wksToUse.Cells.Find(What:="*", _
            LookIn:=xlFormulas, _
            LookAt:=xlPart, _
            SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False)
        lngCol = rngFound.Column
        Set LastUsedCell = wksToUse.Cells(lngRow, lngCol)
    End If
Housekeeping:
    Set rngFound = Nothing
    Exit Function
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Function
 

excelthong

Active Member
Joined
Jul 13, 2006
Messages
295
thank you for the guidance again.
And the more i work on the data then i find some problems

the VBA copy and paste the data
VBA Code:
.Range(.Cells(lngRowBgn, 1), .Cells(lngRow - 1, rngLastCell.Column)).Copy _
1. the VBA copy the data perfectly and paste to newworksheet, however some of my data contain formula and thus return #N/A
May i know how to alter the code to only paste the value of cell?

2. there are other data at AF1 to AH3548, however the Function LastUsedCell(wksToUse) detects the last used cell, thus copy the data for column AF:AH too
May i know how can i set the code only copy the data from column A:AE ?

thank you very much for your help
thong
 

CephasOz

New Member
Joined
Feb 18, 2020
Messages
41
Office Version
365, 2016
Platform
Windows
Hi again excelthong. No worries, just replace the SplitData code with the code below:

VBA Code:
Sub SplitData()
    Const clngDateCol As Long = 2
    Const clngTimeCol As Long = 3
    Dim rngLastCell As Range
    Dim lngRow As Long
    Dim lngRowBgn As Long
    Dim datPrevDate As Date
    Dim strPrevTime As String
    Dim wksNew As Worksheet
    '
    With ActiveSheet
        lngRowBgn = 1
        datPrevDate = .Cells(lngRowBgn, clngDateCol).Value
        strPrevTime = .Cells(lngRowBgn, clngTimeCol).Text
        Set rngLastCell = LastUsedCell(ActiveSheet)
        For lngRow = 2 To rngLastCell.Row + 1
            If ((.Cells(lngRow, clngDateCol).Value <> datPrevDate) Or (.Cells(lngRow, clngTimeCol).Text <> strPrevTime)) Then
                Set wksNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
                wksNew.Name = SheetNameFromDate(datPrevDate)
                .Range(.Cells(lngRowBgn, 1), .Cells(lngRow - 1, "AE")).Copy
                wksNew.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlPasteSpecialOperationNone
                Application.CutCopyMode = False
                lngRowBgn = lngRow
                datPrevDate = .Cells(lngRowBgn, clngDateCol).Value
                strPrevTime = .Cells(lngRowBgn, clngTimeCol).Text
            End If
        Next
        .Activate
    End With
Housekeeping:
    Set rngLastCell = Nothing
    Set wksNew = Nothing
    Exit Sub
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Sub
 

excelthong

Active Member
Joined
Jul 13, 2006
Messages
295
Billion thanks to you again @CephasOz !
this works very well !

i have another question that
column E, column J:M are appeared as text(but they are number)

I google online and know i can record macro to use "text to column" function to convert the text to numbers,
just wondering is that possible to do it in the codes as well

thanks again !!
 

CephasOz

New Member
Joined
Feb 18, 2020
Messages
41
Office Version
365, 2016
Platform
Windows
No worries.

To do this separately, copy the code below into the same module as the previous code, select the worksheet to be modified, then run the Sub.

To add this function into "SplitData", copy just the two lines that start with ".Range" and paste them above the line "For lngRow = 2 To rngLastCell.Row + 1".

This method doesn't change the data in any way, it just changes the way that it is recognised and displayed.

VBA Code:
Sub ConvertTextToNumbers()
    Dim rngLastCell As Range
    Set rngLastCell = LastUsedCell(ActiveSheet)
    With ActiveSheet
        .Range(.Cells(1, "E"), .Cells(rngLastCell.Row, "E")).NumberFormat = vbNullString
        .Range(.Cells(1, "J"), .Cells(rngLastCell.Row, "M")).NumberFormat = vbNullString
    End With
    Set rngLastCell = Nothing
End Sub
 

Forum statistics

Threads
1,089,220
Messages
5,406,927
Members
403,113
Latest member
ms_excel_recal_or_die

This Week's Hot Topics

Top