Create sheet base on the header

Closed
bb - Jun 7, 2010 at 08:24 AM
rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
- Jun 14, 2010 at 09:30 AM
Hi,

Can some one help me?
I have a data with 2 worksheet
1)Data source
2)Data with header

I would like to know how can i match the header with the data source and create the new worksheet using the herder name and copy the data into the new worksheet.

EX: Data source = a, b, c, d
Header =a,b, c, d
Worksheet with be created for a, b, c and d separately

By using the header i will copy all the header with a to worksheet a, b to worksheet b and so on.

I want the macro which can create a new sheet whenever a new header is added and i can update the data source manually.

Appreciate if some one can help on this.


BB



2 replies

rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
769
Jun 7, 2010 at 09:06 AM
I am not sure if all you were asking was to create new sheets, if not already existing
This is based on assumption that headers are on a row. If that a sheet which does not matches the sheet name does not exists, it will create a new sheet with that name


Sub CreateHeaderSheets()
Dim lHeaderRow As Long
Dim sMasterSheet As String
Dim iHeaderStartCol As Integer
Dim iHeaderCols As Integer
Dim iHeaderCol As Integer
Dim sHeader As String


    sMasterSheet = "Sheet1"
    lHeaderRow = 1
    iHeaderStartCol = 1
    
    iHeaderCols = Sheets(sMasterSheet).Cells(lHeaderRow, Columns.Count).End(xlUp).Column
    
    For iHeaderCol = iHeaderStartCol To iHeaderCols
    
        sHeader = Sheets(sMasterSheet).Cells(lHeaderRow, iHeaderCol)
            
        If sHeader <> "" Then
                
            On Error Resume Next
            
                Sheets(sHeader).Select
                
            On Error GoTo 0
            
            If ActiveSheet.Name <> sHeader Then
            
                Sheets.Add
                ActiveSheet.Name = sHeader
            
            End If
            
        End If
        
        
    Next iHeaderCol
        
End Sub
0
Thanks Rizvisa,

That's something i need.
But before create the new sheet.I need to match the data in data source sheet.If it is matched, new sheet will be created.else msg promp to ask user to update the data source.
After create the new sheet.I want to copy the column with the header to the sheet name which same with header

thanks if could provide for this.
bb
0
added on the above, how can i remove the symbol if the header contain of "/ # $ % & ^".As new sheet created can't contain of symbol.
0
rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
769
Jun 7, 2010 at 10:56 AM
Could you please upload a sample file with sample data etc on some shared site like https://authentification.site , http://wikisend.com/ ,https://accounts.google.com/ServiceLogin?passive=1209600&continue=https://docs.google.com/&followup=https://docs.google.com/&emr=1 http://www.editgrid.com etc and post back here the link to allow better understanding of how it is now and how you foresee
0
rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
769
Jun 7, 2010 at 04:12 PM
File not found. It has been either deleted, or it never existed at all.
0
rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
769
Jun 10, 2010 at 03:49 AM
Run FixMe routine only


Sub fixme()
Dim lMaxRows As Long
Dim iMaxCols As Integer
Dim sHeaderSheet As String
Dim sDataSheet As String
Dim iCol As Integer

    sHeaderSheet = "Data source"
    sDataSheet = "Sheet1"
    
    Sheets(sHeaderSheet).Select
    
    lMaxRows = 0
    
    On Error Resume Next
        lMaxRows = Cells.Find("*", Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        iMaxCols = Cells.Find("*", Cells(1, 1), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    On Error GoTo 0
    
    If lMaxRows < 2 Then Exit Sub
    
    With Range(Cells(2, iMaxCols), Cells(lMaxRows, iMaxCols))
        
        .FormulaR1C1 = "=IF(ISERROR(MATCH(RC1, " & sDataSheet & "!R1:R1, 0)), 0,MATCH(RC1, " & sDataSheet & "!R1:R1, 0))"
        .Copy
        .PasteSpecial xlPasteValues
    
    End With
    
    
    If (WorksheetFunction.CountIf(Range(Cells(2, iMaxCols), Cells(lMaxRows, iMaxCols)), "=0") > 0) Then
        Range(Cells(2, iMaxCols), Cells(lMaxRows, iMaxCols)).Clear
        MsgBox ("Please update the data source.")
        Exit Sub
    End If
    
    For iCol = 2 To lMaxRows
    
        Call CopyData(sDataSheet, Cells(lMaxRows, 1), Cells(lMaxRows, iMaxCols))
        
    Next iCol
End Sub


Sub CopyData(sFromSheet As String, CopyHeader As String, CopyCol As Integer, Optional Append As Boolean = True)
Dim sActiveSheet As String
Dim lMaxRows As Long
Dim lMaxDataRows As Long
Dim sCol As String

    sCol = Cells(1, CopyCol).Address(False, False)
    sCol = Left(sCol, Len(sCol) - 1)
    
    sActiveSheet = ActiveSheet.Name
    
    On Error Resume Next
        Sheets(CopyHeader).Select
    On Error GoTo 0
    
    If (ActiveSheet.Name <> CopyHeader) Then
        Sheets.Add
        ActiveSheet.Name = CopyHeader
    End If
    
    
    On Error Resume Next
        lMaxRows = Cells.Find("*", Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lMaxDataRows = Sheets(sFromSheet).Cells.Find("*", Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    On Error GoTo 0

    If ((Not Append) Or lMaxRows = 0) Then
        
        Columns(1).Clear
        Sheets(CopyHeader).Range("A:A") = Sheets(sFromSheet).Range(sCol & ":" & sCol).Value
    
    Else
        
        Sheets(sFromSheet).Select
        Range(Cells(2, sCol), Cells(lMaxDataRows, sCol)).Copy
        
        Sheets(CopyHeader).Select
        Cells(lMaxRows + 1, "A").Select
        Selection.PasteSpecial xlPasteValues
        
    End If
    
End Sub
0
run time error '1004'
application -defined or object-defined error

when click debug: yellow highlighted as per below code
sCol = Cells(1, CopyCol).Address(False, False)
0
rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
769
Jun 14, 2010 at 09:30 AM
What version of excel you use
0