How do i copy data to other sheets based on cell value

Question

I have a data sheet where there is presented Name, personal number, email etc. I have around 500 Rows with person data, that needs the data separated in different sheets sorted after names. I have color coded the persons data and the sheets to where their data should go.

I have made an vba that can make sheets with the given 500 names, but have no clue on how to copy the data to the right sheets based on the cell value with their names.

I only know how to copy with the:

Sheets("Sheet1").Range("A2:A15").Copy Destination:=Sheets("Susanne Koch Jensen").Range("A1")

But that will take ages if i have to move for 500 people.

Link to image of the table color coded

Answer 1

Here are three alternatives to illustrate how to solve it

The preferred one would be the look up formula in a "printable" sheet, but as you say you're learning, I coded the other options.

Read the comments in each one, adjust the parameters, and go through the code pressing F8 so you see what happens in each line. Test all three Public procedures.

For option 1 , setup a sheet called Printable like this:

Lookup formula: =INDEX(Sheet1!$A2:$C2;;$B$1) specifying $A2:$C2 where A to C are the columns in your source sheet with data (may be the 500 columns) and 2 is the row that correspond to the name (if you copy down, it's refer to the other rows)

---

Copy the following code to a module

Option Explicit

' OPTION 1
' Have a printable sheet with lookup formulas and print that sheet
Public Sub LookupAndPrint()

    Dim sourceSheet As Worksheet
    Dim printableSheet As Worksheet

    Dim firstColumn As Long
    Dim lastColumn As Long
    Dim nameRow As Long
    Dim counter As Long

    Dim sourcePath As String
    Dim fileName As String

    ' Adjust the following parameters
    Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
    Set printableSheet = ThisWorkbook.Worksheets("Printable")

    firstColumn = 2 ' = B
    nameRow = 2 ' Relative to sheet

    ' Get the last column with data
    lastColumn = sourceSheet.Cells(nameRow, sourceSheet.Columns.Count).End(xlToLeft).Column

    ' Get current file path
    sourcePath = ThisWorkbook.path

    For counter = firstColumn To lastColumn

        ' Set the lookup column's number
        printableSheet.Range("B1").Value = counter

        ' Set the file name
        fileName = printableSheet.Range("B3").Value
        fileName = Replace(fileName, ".", "_")
        fileName = Replace(fileName, " ", "")

        ' Export the sheet
        exportToPDF printableSheet, sourcePath, fileName

    Next counter

End Sub

Private Sub exportToPDF(ByVal sourceSheet As Worksheet, ByVal path As String, ByVal fileName As String)

    Dim cleanFileName As String
    Dim fullPath As String

    cleanFileName = Replace(fileName, ".", "_")
    cleanFileName = Replace(cleanFileName, " ", "")

    fullPath = path & "\" & cleanFileName

    sourceSheet.ExportAsFixedFormat xlTypePDF, fullPath

End Sub


' OPTION 2
' You can hide other columns and export to PDF
Public Sub HideColumnsAndPrintToPDF()

    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim evalRange As Range
    Dim sourceColumn As Range

    Dim firstRow As Long
    Dim lastRow As Long
    Dim firstColumn As Long
    Dim lastColumn As Long
    Dim nameRow As Long

    Dim sourcePath As String

    ' Adjust the following parameters
    Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")

    firstRow = 2
    lastRow = 15
    firstColumn = 2 ' = B
    nameRow = 1 ' Relative to firstRow



    ' Get the last column with data
    lastColumn = sourceSheet.Cells(firstRow, sourceSheet.Columns.Count).End(xlToLeft).Column

    ' Set the evaluated range
    Set evalRange = sourceSheet.Range(sourceSheet.Cells(firstRow, firstColumn), sourceSheet.Cells(lastRow, lastColumn))

    ' Get current file path
    sourcePath = ThisWorkbook.path

    ' Loop through each column in range
    For Each sourceColumn In evalRange.Columns

        ' Hide other columns
        hideOtherColumns sourceColumn.Column, evalRange

        ' Export to pdf
        exportToPDF sourceSheet, sourcePath, sourceColumn.Cells(nameRow).Value

    Next sourceColumn

End Sub

Private Sub hideOtherColumns(ByVal currentColumn As Long, ByVal evalRange As Range)

    Dim evalColumn As Range

    For Each evalColumn In evalRange.Columns

        evalColumn.EntireColumn.Hidden = (evalColumn.Column <> currentColumn)

    Next evalColumn

End Sub



' OPTION 3
' If you plan to copy data to sheets
Public Sub CopyDataToSheets()

    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim evalRange As Range
    Dim sourceColumn As Range

    Dim firstRow As Long
    Dim lastRow As Long
    Dim firstColumn As Long
    Dim lastColumn As Long
    Dim nameRow As Long

    Dim sourcePath As String

    ' Adjust the following parameters
    Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")

    firstRow = 2
    lastRow = 15
    firstColumn = 2 ' = B
    nameRow = 1 ' Relative to firstRow



    ' Get the last column with data
    lastColumn = sourceSheet.Cells(firstRow, sourceSheet.Columns.Count).End(xlToLeft).Column

    ' Set the evaluated range
    Set evalRange = sourceSheet.Range(sourceSheet.Cells(firstRow, firstColumn), sourceSheet.Cells(lastRow, lastColumn))

    ' Get current file path
    sourcePath = ThisWorkbook.path

    ' Loop through each column in range
    For Each sourceColumn In evalRange.Columns

        ' Get the sheet based on the name
        Set targetSheet = getSheet(sourceColumn.Cells(nameRow).Value)

        ' Check that a sheet was found
        If Not targetSheet Is Nothing Then

            ' Copy data to sheet
            sourceColumn.Copy Destination:=targetSheet.Range("A1")

            ' Export to pdf
            exportToPDF targetSheet, sourcePath, sourceColumn.Cells(nameRow).Value

        End If

    Next sourceColumn

End Sub

Private Function getSheet(ByVal sheetName As String) As Worksheet

    Dim sheet As Worksheet

    For Each sheet In ThisWorkbook.Worksheets
        ' Use this if names are approximate, or: sheet.name = sheetName if names should be equal
        If InStr(LCase$(sheet.Name), LCase$(sheetName)) > 0 Then ' If sheet.name = sheetName then
            Set getSheet = sheet
        End If
    Next sheet

End Function

Let me know if it works