escobf,
Thanks for the workbook.
With your raw data in worksheet Sheet1, the macro will create a new worksheet Results.
Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).
1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.
Option Explicit
Sub ReorgData()
' stanleydgromjr, 04/12/2013
' http://www.excelforum.com/excel-general/914529-create-continuous-non-blank-table-based-on-merge-of-separate-dynamically-filled-tables.html
Dim w1 As Worksheet, wR As Worksheet
Dim Area As Range, r As Long, sr As Long, er As Long, nr As Long, lr As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
w1.Cells(1, 1).Resize(, 5).Copy wR.Cells(1, 1)
wR.Cells(1, 5).Copy wR.Cells(1, 6).Resize(, 2)
wR.Cells(1, 6).Resize(, 2).Value = [{"Calc1","Calc2"}]
For Each Area In w1.Range("B1", w1.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
With Area
sr = .Row
er = sr + .Rows.Count - 1
nr = wR.Range("B" & Rows.Count).End(xlUp).Offset(1).Row
wR.Range("B" & nr).Resize(er - sr, 4).Value = w1.Range("B" & sr + 1 & ":E" & er).Value
End With
Next Area
lr = wR.Cells(Rows.Count, 2).End(xlUp).Row
With wR.Range("A2:A" & lr)
.Formula = "=ROW()-1"
.Value = .Value
End With
For r = 2 To lr Step 2
With wR.Range("A" & r & ":G" & r).Interior
.Pattern = xlSolid
.PatternThemeColor = xlThemeColorAccent1
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799951170384838
.PatternTintAndShade = 0.799981688894314
End With
Next r
wR.Range("A2:G" & lr).Borders.Weight = xlThin
wR.Columns("C:D").AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub
Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm
Then run the ReorgData macro.
Bookmarks