Sub ExtractData()
Dim srcWb As Workbook
Dim destWs As Worksheet
Dim srcWs As Worksheet
Dim lastRow As Long
Dim outputLastRow As Long
Dim tableHeaders As Variant
Dim i As Long
' Set source workbook and sheet
On Error Resume Next
Set srcWb = Workbooks("Classeur1.xlsx") ' Change extension if needed
On Error GoTo 0
If srcWb Is Nothing Then
MsgBox "Classeur1.xlsx is not open. Please open it and try again.",
vbExclamation
Exit Sub
End If
Set srcWs = srcWb.Sheets("Feuil1")
Set destWs = ThisWorkbook.Sheets(1) ' Set this to the appropriate sheet in your
template
' Clear previous data in destination sheet (optional)
destWs.Cells.Clear
' Define the headers for the output table
tableHeaders = Array("A", "G", "Q", "S", "T", "U", "V", "Y")
' Copy headers from source to destination
For i = LBound(tableHeaders) To UBound(tableHeaders)
destWs.Cells(1, i + 1).Value = srcWs.Cells(1,
Columns(tableHeaders(i)).Column).Value
Next i
' Find the last row in source sheet
lastRow = srcWs.Cells(srcWs.Rows.Count, "A").End(xlUp).Row
' Copy data from source sheet to destination sheet based on defined columns
For i = 2 To lastRow ' Start from row 2 to skip headers
outputLastRow = destWs.Cells(destWs.Rows.Count, 1).End(xlUp).Row + 1
destWs.Cells(outputLastRow, 1).Value = srcWs.Cells(i, 1).Value ' Column A -
> A
destWs.Cells(outputLastRow, 2).Value = srcWs.Cells(i, 7).Value ' Column G -
> B
destWs.Cells(outputLastRow, 3).Value = srcWs.Cells(i, 17).Value ' Column Q
-> C
destWs.Cells(outputLastRow, 4).Value = srcWs.Cells(i, 19).Value ' Column S
-> D
destWs.Cells(outputLastRow, 5).Value = srcWs.Cells(i, 20).Value ' Column T
-> E
destWs.Cells(outputLastRow, 6).Value = srcWs.Cells(i, 21).Value ' Column U
-> F
destWs.Cells(outputLastRow, 7).Value = srcWs.Cells(i, 22).Value ' Column V
-> G
destWs.Cells(outputLastRow, 8).Value = srcWs.Cells(i, 25).Value ' Column Y
-> H
Next i
' Sort the data in the destination sheet by column C (3rd column) after header
With destWs.Sort
.SortFields.Clear
.SortFields.Add Key:=destWs.Range("C2:C" & outputLastRow),
Order:=xlAscending
.SetRange destWs.Range("A1:H" & outputLastRow)
.Header = xlYes
.Apply
End With
' Hide columns after H
destWs.Columns("I:Z").EntireColumn.Hidden = True
' Auto-fit the column widths
destWs.Columns("A:H").AutoFit
MsgBox "Data extraction and formatting complete.", vbInformation
End Sub
