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().Range("A1")
But that will take ages if i have to move for 500 people.
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