Create sheet base on the header [Closed]

Report
-
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
-
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

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
761
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
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
761
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
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
761
File not found. It has been either deleted, or it never existed at all.
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
761
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
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)
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
761
What version of excel you use

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!