This is the code I wrote post R&D and using Chatgpt. The code is creating blank sheets but now the file I need with the data. Please help..
VBA Code:
Sub GenerateDSR()
Dim wsSource As Worksheet
Dim wsReference As Worksheet
Dim wsDest As Worksheet
' Set references to the source, reference, and destination sheets
Set wsSource = ThisWorkbook.Sheets("Source")
Set wsReference = ThisWorkbook.Sheets("Reference")
' Get the selected customer name from the drop-down list in cell B2
Dim customerName As String
customerName = wsSource.Range("B2").Value
' Find the customer name in the reference sheet
Dim customerRange As Range
Set customerRange = wsReference.Range("B1:BX1").Find(customerName, LookIn:=xlValues, LookAt:=xlWhole)
' Check if the customer name is found
If customerRange Is Nothing Then
MsgBox "Customer name '" & customerName & "' not found in the reference sheet.", vbExclamation
Exit Sub
End If
' Determine the column number of the customer name in the reference sheet
Dim customerCol As Long
customerCol = customerRange.Column
' Get the headers for the current customer from the reference sheet
Dim headerRange As Range
Set headerRange = wsReference.Range(wsReference.Cells(2, customerCol), wsReference.Cells(wsReference.Rows.Count, customerCol).End(xlUp))
' Create a new destination sheet for the customer report
Set wsDest = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsDest.Name = Left(customerName, 31) & " DSR"
' Copy the headers to the destination sheet
headerRange.Copy wsDest.Cells(1, 1)
' Find the last row in the source sheet
Dim lastRow As Long
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
' Loop through the source data and copy relevant columns to the destination sheet
Dim srcRow As Long
Dim destRow As Long
destRow = 2 ' Start copying from the second row in the destination sheet
For srcRow = 4 To lastRow ' Start from the fourth row in the source sheet
If wsSource.Cells(srcRow, 6).Value = customerName Then ' Check if the customer name matches
Dim destColumn As Long
destColumn = 1
For Each headerCell In headerRange
Dim headerRow As Range
Set headerRow = wsSource.Rows(3).Find(headerCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not headerRow Is Nothing Then
wsDest.Cells(destRow, destColumn).Value = wsSource.Cells(srcRow, headerRow.Column).Value
End If
destColumn = destColumn + 1
Next headerCell
destRow = destRow + 1
End If
Next srcRow
' Autofit columns in the destination sheet
wsDest.UsedRange.Columns.AutoFit
' Clear the selection in the source sheet
wsSource.Select
MsgBox "DSR generated for customer: " & customerName, vbInformation
End Sub
Last edited by a moderator:
