Combining two date ranges into one

macutna,

Welcome to the Excel Forum.

You are posting a picture. This means that if this was a problem where one needed to use your data, anyone trying to help you would have to enter the data manually. That makes no sense and I doubt that you would get any answer.

To get the most precise answer, it is best to upload/attach a sample workbook (sensitive data scrubbed/removed/changed) that contains an example of your raw data on one worksheet, and on another worksheet your desired results.

The structure and data types of the sample workbook must exactly duplicate the real workbook. Include a clear and explicit explanation of your requirements.

To attach your workbook, scroll down and click on the Go Advanced button, then scroll down and click on the Manage Attachments button.

macutna,

When responding to someone's reply, please do not quote their entire reply. Thanks.

Sorry I took so long. I was trying to create a macro using arrays.


Detach/open workbook ReorgData - macutna - EF785649 - SDG12.xls, and run the ReorgData macro.



If you want to use the macro on another workbook:


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, 07/26/2011
' http://www.excelforum.com/excel-programming/785649-combining-two-date-ranges-into-one.html
Dim LR As Long, a As Long, NR As Long, FR As Long
Application.ScreenUpdating = False
Range("G1") = "DATE"
LR = Cells(Rows.Count, 1).End(xlUp).Row
For a = 2 To LR Step 1
  FR = 0
  On Error Resume Next
  FR = Application.Match(Cells(a, 1), Columns(4), 0)
  On Error GoTo 0
  If FR > 0 Then
    NR = Range("G" & Rows.Count).End(xlUp).Offset(1).Row
    Cells(NR, 7).Value = Cells(a, 1).Value
  End If
Next a
LR = Cells(Rows.Count, 4).End(xlUp).Row
For a = 2 To LR Step 1
  FR = 0
  On Error Resume Next
  FR = Application.Match(Cells(a, 4), Columns(1), 0)
  On Error GoTo 0
  If FR > 0 Then
    NR = Range("G" & Rows.Count).End(xlUp).Offset(1).Row
    Cells(NR, 7).Value = Cells(a, 4).Value
  End If
Next a
Columns(7).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(8), Unique:=True
Columns(7).Delete
LR = Cells(Rows.Count, 7).End(xlUp).Row
With Range("G2:G" & LR)
  .Sort Key1:=Range("G2"), order1:=2, Header:=xlNo
  .NumberFormat = "d-mmm-yy"
End With
With Range("G1:I1")
  .Value = [{"DATE","DATA1","DATA2"}]
  .Font.Bold = True
End With
Range("H2:H" & LR).FormulaR1C1 = "=INDEX(C[-6],MATCH(RC[-1],C[-7],0),1)"
Range("I2:I" & LR).FormulaR1C1 = "=INDEX(C[-4],MATCH(RC[-2],C[-5],0),1)"
With Range("G1:I" & LR)
  .HorizontalAlignment = xlCenter
  .Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.

macutna,

The following should be a lot faster using arrays, especially if there is a lot of data in worksheet Sheet1.


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 ReorgDataV2()
' stanleydgromjr, 07/26/2011
' http://www.excelforum.com/excel-programming/785649-combining-two-date-ranges-into-one.html
Dim a, b, d, e, d1 As Object, q
Dim r As Long, rr As Long, i As Long
Dim fr As Long, fr2 As Long, c()
Application.ScreenUpdating = False
Worksheets("Sheet1").Activate
Set d1 = CreateObject("scripting.dictionary")
r = Range("A:A")(Rows.Count).End(3).Row
a = Range("A1:A" & r)
b = Range("B1:B" & r)
rr = Range("D:D")(Rows.Count).End(3).Row
d = Range("D1:D" & rr)
e = Range("E1:E" & rr)
For i = 2 To r Step 1
  fr = 0
  On Error Resume Next
  fr = Application.Match(a(i, 1), d, 0)
  On Error GoTo 0
  If fr > 0 Then
    If Not d1.exists(a(i, 1)) Then d1(a(i, 1)) = d1.Count
  End If
Next i
For i = 2 To rr Step 1
  fr = 0
  On Error Resume Next
  fr = Application.Match(d(i, 1), a, 0)
  On Error GoTo 0
  If fr > 0 Then
    If Not d1.exists(d(i, 1)) Then d1(d(i, 1)) = d1.Count
  End If
Next i
q = d1.Keys
ReDim c(1 To d1.Count + 1, 1 To 3)
For i = 1 To d1.Count
  c(i + 1, 1) = q(i - 1)
Next i
c(1, 1) = "Date": c(1, 2) = "DATA1": c(1, 3) = "DATA2"
For i = 2 To UBound(c) Step 1
  fr = 0
  On Error Resume Next
  fr = Application.Match(c(i, 1), a, 0)
  On Error GoTo 0
  If fr > 0 Then
    c(i, 2) = b(fr, 1)
  End If
  fr2 = 0
  On Error Resume Next
  fr = Application.Match(c(i, 1), d, 0)
  On Error GoTo 0
  If fr > 0 Then
    c(i, 3) = e(fr, 1)
  End If
Next i
Range("G1").Resize(UBound(c), 3) = c
Range("G1:I1").Font.Bold = True
Range("G2:G" & UBound(c)).NumberFormat = "d-mmm-yy"
With Range("G1:I" & UBound(c))
  .HorizontalAlignment = xlCenter
  .Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Then run the ReorgDataV2 macro.