Option Explicit
Sub RerogData()
' hiker95, 04/17/2013
' http://www.mrexcel.com/forum/excel-questions/697218-advanced-text-formating-excel-visual-basic-applications.html
Dim ws As Worksheet, wx As Worksheet
Dim r As Long, lr As Long, lrd As Long, nrx As Long, refs As String
Dim n As Long 'n count column B *kg
Application.ScreenUpdating = False
Set wx = Worksheets("xdetail")
wx.Cells(1, 1).Resize(, 15).Value = [{"Name","Cat. No.","Size","Clone","USE","U#","cost","type","Reaction","Con.","Laser","Excite","Applications","Description","References"}]
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "xdetail" And ws.Name <> "ydetail" Then
ws.Columns("D:R").ClearContents
With ws.Cells(1, 4).Resize(, 15)
.Value = [{"Name","Cat. No.","Size","Clone","USE","U#","cost","type","Reaction","Con.","Laser","Excite","Applications","Description","References"}]
.Font.Bold = True
End With
n = Application.CountIf(ws.Columns(2), "*kg")
lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
For r = 1 To lr Step 1
If ws.Cells(r, 1) <> "" Then
If InStr(ws.Cells(r, 1), "Clone:") > 0 Then
ws.Cells(2, 7).Resize(n).Value = ws.Cells(r, 1).Value
ElseIf InStr(ws.Cells(r, 1), "USE:") > 0 Then
ws.Cells(2, 8).Resize(n).Value = ws.Cells(r, 1).Value
ElseIf InStr(ws.Cells(r, 1), "U#") > 0 Then
ws.Cells(2, 9).Resize(n).Value = ws.Cells(r, 1).Value
ElseIf InStr(ws.Cells(r, 1), "Cat. No") > 0 Then
ws.Cells(2, 5).Resize(n, 2).Value = ws.Cells(r + 1, 1).Resize(n, 2).Value
ElseIf InStr(ws.Cells(r, 1), "Data for") > 0 Then
ws.Cells(2, 4).Resize(n).Value = Right(ws.Cells(r, 1), Len(ws.Cells(r, 1)) - 9)
ElseIf InStr(ws.Cells(r, 1), "cost") > 0 Then
ws.Cells(2, 10).Resize(n).Value = ws.Cells(r, 2).Value
ElseIf InStr(ws.Cells(r, 1), "type") > 0 Then
ws.Cells(2, 11).Resize(n).Value = ws.Cells(r, 2).Value
ElseIf InStr(ws.Cells(r, 1), "Reaction") > 0 Then
ws.Cells(2, 12).Resize(n).Value = ws.Cells(r, 2).Value
ElseIf InStr(ws.Cells(r, 1), "Con.") > 0 Then
ws.Cells(2, 13).Resize(n).Value = ws.Cells(r, 2).Value
ElseIf InStr(ws.Cells(r, 1), "Laser") > 0 Then
ws.Cells(2, 14).Resize(n).Value = ws.Cells(r, 2).Value
ElseIf InStr(ws.Cells(r, 1), "Excite") > 0 Then
ws.Cells(2, 15).Resize(n).Value = ws.Cells(r, 2).Value
ElseIf InStr(ws.Cells(r, 1), "Application") > 0 Then
ws.Cells(2, 16).Resize(n).Value = ws.Cells(r, 2).Value
ElseIf InStr(ws.Cells(r, 1), "Description") > 0 Then
ws.Cells(2, 17).Resize(n).Value = ws.Cells(r, 1).Value
ElseIf InStr(ws.Cells(r, 1), "References:") > 0 Then
refs = ""
refs = ws.Cells(r, 1).Value
ElseIf InStr(ws.Cells(r, 1), ";") > 0 And InStr(ws.Cells(r, 1), ":") > 0 Then
refs = refs & "/" & ws.Cells(r, 1)
End If
End If
Next r
ws.Cells(2, 18).Resize(n).Value = refs
ws.Cells.EntireColumn.AutoFit
lrd = ws.Cells(Rows.Count, "D").End(xlUp).Row
nrx = wx.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wx.Cells(nrx, 1).Resize(n, 15).Value = ws.Range(ws.Cells(2, 4), ws.Cells(lrd, 18)).Value
End If
Next ws
wx.Cells.EntireColumn.AutoFit
wx.Activate
Application.ScreenUpdating = True
End Sub
[code/]
Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension [b].xlsm[/b]
Then run the [B]RerogData[/B] macro.
