Option Explicit
Sub ReorgData()
' hiker95, 02/12/2014, ME756540
Dim lr As Long, nr As Long, strColName As String
Dim w1derng As Range, wqderng As Range
Dim w1skrng As Range, wqskrng As Range
Dim w1snrng As Range, wqsnrng As Range
Dim w1sdrng As Range, wqsdrng As Range
Dim w1edrng As Range, wqedrng As Range
Dim w1qtrng As Range, wqqtrng As Range
Dim w1burng As Range, wqburng As Range
Dim w1slrng As Range, wqslrng As Range
Dim w1sirng As Range, wqsirng As Range
With Sheets("Sheet1")
Set w1derng = .Rows(1).Find("Description", LookAt:=xlWhole)
Set w1skrng = .Rows(1).Find("Covered SKU", LookAt:=xlWhole)
Set w1snrng = .Rows(1).Find("Serial No", LookAt:=xlWhole)
Set w1sdrng = .Rows(1).Find("Start Date", LookAt:=xlWhole)
Set w1edrng = .Rows(1).Find("End Date", LookAt:=xlWhole)
Set w1qtrng = .Rows(1).Find("Qty", LookAt:=xlWhole)
Set w1burng = .Rows(1).Find("Buy Price", LookAt:=xlWhole)
Set w1slrng = .Rows(1).Find("Service Level", LookAt:=xlWhole)
Set w1sirng = .Rows(1).Find("Host Name", LookAt:=xlWhole)
If (w1derng Is Nothing) * (w1skrng Is Nothing) * (w1snrng Is Nothing) _
* (w1sdrng Is Nothing) * (w1edrng Is Nothing) * (w1qtrng Is Nothing) _
* (w1burng Is Nothing) * (w1slrng Is Nothing) * (w1sirng Is Nothing) Then
MsgBox "At least one of the 9 titles in sheet 'Sheet1' is missing - macro terminated!"
Exit Sub
End If
End With
With Sheets("QUOTE")
Set wqderng = .Rows(1).Find("Description", LookAt:=xlWhole)
Set wqskrng = .Rows(1).Find("Service Code", LookAt:=xlWhole)
Set wqsnrng = .Rows(1).Find("Serial Number", LookAt:=xlWhole)
Set wqsdrng = .Rows(1).Find("Start Date", LookAt:=xlWhole)
Set wqedrng = .Rows(1).Find("End Date", LookAt:=xlWhole)
Set wqqtrng = .Rows(1).Find("Qty", LookAt:=xlWhole)
Set wqburng = .Rows(1).Find("Buy", LookAt:=xlWhole)
Set wqslrng = .Rows(1).Find("Service Level", LookAt:=xlWhole)
Set wqsirng = .Rows(1).Find("Site", LookAt:=xlWhole)
If (wqderng Is Nothing) * (wqskrng Is Nothing) * (wqsnrng Is Nothing) _
* (wqsdrng Is Nothing) * (wqedrng Is Nothing) * (wqqtrng Is Nothing) _
* (wqburng Is Nothing) * (wqslrng Is Nothing) * (wqsirng Is Nothing) Then
MsgBox "At least one of the 9 titles in sheet 'QUOTE' is missing - macro terminated!"
Exit Sub
ElseIf (Not wqderng Is Nothing) * (Not wqskrng Is Nothing) * (Not wqsnrng Is Nothing) _
* (Not wqsdrng Is Nothing) * (Not wqedrng Is Nothing) * (Not wqqtrng Is Nothing) _
* (Not wqburng Is Nothing) * (Not wqslrng Is Nothing) * (Not wqsirng Is Nothing) Then
lr = .Cells(Rows.Count, wqderng.Column).End(xlUp).Row
strColName = Replace(.Cells(1, w1derng.Column).Address(0, 0), 1, "")
nr = Sheets("Sheet1").Range(strColName & Rows.Count).End(xlUp).Offset(1).Row
.Range(.Cells(2, wqderng.Column), .Cells(lr, wqderng.Column)).Copy Sheets("Sheet1").Cells(nr, w1derng.Column)
.Range(.Cells(2, wqskrng.Column), .Cells(lr, wqskrng.Column)).Copy Sheets("Sheet1").Cells(nr, w1skrng.Column)
.Range(.Cells(2, wqsnrng.Column), .Cells(lr, wqsnrng.Column)).Copy Sheets("Sheet1").Cells(nr, w1snrng.Column)
.Range(.Cells(2, wqsdrng.Column), .Cells(lr, wqsdrng.Column)).Copy Sheets("Sheet1").Cells(nr, w1sdrng.Column)
.Range(.Cells(2, wqedrng.Column), .Cells(lr, wqedrng.Column)).Copy Sheets("Sheet1").Cells(nr, w1edrng.Column)
.Range(.Cells(2, wqqtrng.Column), .Cells(lr, wqqtrng.Column)).Copy Sheets("Sheet1").Cells(nr, w1qtrng.Column)
.Range(.Cells(2, wqburng.Column), .Cells(lr, wqburng.Column)).Copy Sheets("Sheet1").Cells(nr, w1burng.Column)
.Range(.Cells(2, wqslrng.Column), .Cells(lr, wqslrng.Column)).Copy Sheets("Sheet1").Cells(nr, w1slrng.Column)
.Range(.Cells(2, wqsirng.Column), .Cells(lr, wqsirng.Column)).Copy Sheets("Sheet1").Cells(nr, w1sirng.Column)
End If
End With
With Sheets("Sheet1")
.Columns.AutoFit
.Activate
End With
End Sub