Results 1 to 7 of 7

Create continuous non blank table based on merge of separate dynamically filled tables

Threaded View

escobf Create continuous non blank... 04-12-2013, 11:35 AM
stanleydgromjr Re: Create continuous non... 04-12-2013, 01:36 PM
escobf Re: Create continuous non... 04-12-2013, 02:22 PM
escobf Re: Create continuous non... 04-12-2013, 04:50 PM
stanleydgromjr Re: Create continuous non... 04-12-2013, 08:57 PM
escobf Re: Create continuous non... 04-15-2013, 10:13 AM
stanleydgromjr Re: Create continuous non... 04-15-2013, 04:15 PM
  1. #5
    Forum Expert
    Join Date
    10-10-2008
    Location
    Northeast Pennsylvania, USA
    MS-Off Ver
    Excel 2007
    Posts
    2,387

    Re: Create continuous non blank table based on merge of separate dynamically filled tables

    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.
    Last edited by stanleydgromjr; 04-12-2013 at 09:01 PM.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1