VBA code to copy data matching criteria to new sheet and copy specific rows in between

V

vbanewbie2011

New Member
Joined
Sep 6, 2011
Messages
5
Hello! I am relatively new to VBA and have been searching for a few weeks for a code that will do the following:

I need to copy all data in a row from a "Master" sheet to individual sheets (in the same workbook) where the ID on the Master sheet match the individual sheet names while also copying the row titles/headings. My problem is on the Master sheet, the first 6 rows are "section titles", as are rows 17-19 and rows 96-98. Rows 7, 20, & 99 are "headers".

For example: There is one instance of ID "11" under Section 1 (cell A8), three instances under Section 2 (cells A21, A22, & A23), and one instance under Section 3 (cell A100). On the sheet named "11", I need each Section heading with the corresponding data shown below each.

For instances where an ID may not appear under all 3 sections, I would like the text "Section Not Applicable" to appear below the section title.

I have an example file that may provide a better visual- let me know how to send if you'd like the file. Any help would be GREATLY appreciated!!! Thank you!
 
Sort by date Sort by votes
vbanewbie2011,

I ran the macro against your new data.

I found that worksheet 85 did not have a Section 2.

I added some code after processing Setction 2's data, that checks each worksheet for a Section 2. If the section was missing, then it is added.


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).


Code: 
Option Explicit
Sub DistributeDataV2()
' hiker95, 09/09/2011
' http://www.mrexcel.com/forum/showthread.php?t=577018
Dim wM As Worksheet, ws As Worksheet
Dim MyS1 As Long, MyS2 As Long, MyS3 As Long, LR As Long, LUR As Long
Dim MyC1 As Long, MyC2 As Long, MyC3 As Long
Dim TR As Long, FR As Long, ER As Long, a As Long, NR As Long, N As String
Application.ScreenUpdating = False
Set wM = Worksheets("Master")
MyS1 = Application.Match("Section 1: Major Change", wM.Columns(1), 0)
MyS2 = Application.Match("Section 2: Minor Change", wM.Columns(1), 0)
MyS3 = Application.Match("Section 3: Supposed to Change but Didn't", wM.Columns(1), 0)
LR = wM.Cells(Rows.Count, 1).End(xlUp).Row
'********** Section 1: Major Change **********
TR = MyS1 + 2
FR = MyS1 + 3
ER = MyS2 - 4
For a = FR To ER Step 1
  If Not Evaluate("ISREF(" & wM.Cells(a, 1) & "!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = wM.Cells(a, 1)
  N = wM.Cells(a, 1)
  Set ws = Worksheets(N)
  MyC1 = 0
  On Error Resume Next
  MyC1 = Application.Match("Section 1: Major Change", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC1 = 0 Then
    ws.Cells.Interior.ColorIndex = 2
    wM.Range("A1:L7").Copy ws.Range("A1:L7")
    wM.Range("A1:L1").Copy
    With ws.Range("A1:L1")
      .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  Else
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  End If
Next a
'********** Section 2: Minor Change **********
TR = MyS2 + 2
FR = MyS2 + 3
ER = MyS3 - 4
For a = FR To ER Step 1
  If Not Evaluate("ISREF(" & wM.Cells(a, 1) & "!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = wM.Cells(a, 1)
  N = wM.Cells(a, 1)
  Set ws = Worksheets(N)
  MyC1 = 0
  On Error Resume Next
  MyC1 = Application.Match("Section 1: Major Change", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC1 = 0 Then
    ws.Cells.Interior.ColorIndex = 2
    wM.Range("A1:L7").Copy ws.Range("A1:L7")
    wM.Range("A1:L1").Copy
    With ws.Range("A1:L1")
      .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    ws.Range("A" & NR) = "Section Not Applicable"
    With ws.Range("A" & NR & ":L" & NR)
      .HorizontalAlignment = xlCenter
      .MergeCells = True
      .Interior.ColorIndex = 2
    End With
  End If
  MyC2 = 0
  On Error Resume Next
  MyC2 = Application.Match("Section 2: Minor Change", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC2 = 0 Then
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(2).Row
    wM.Range("A" & MyS2 & ":L" & MyS2 + 2).Copy ws.Range("A" & NR)
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  Else
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  End If
Next a
'********** Check each worksheet for "Section 2: Minor Change" **********
For Each ws In ThisWorkbook.Worksheets
  If ws.Name <> "Instructions" And ws.Name <> "Master" Then
    MyC2 = 0
    On Error Resume Next
    MyC2 = Application.Match("Section 2: Minor Change", ws.Columns(1), 0)
    On Error GoTo 0
    If MyC2 = 0 Then
      NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(2).Row
      wM.Range("A" & MyS2 & ":L" & MyS2 + 2).Copy ws.Range("A" & NR)
      NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      ws.Range("A" & NR) = "Section Not Applicable"
      With ws.Range("A" & NR & ":L" & NR)
        .HorizontalAlignment = xlCenter
        .MergeCells = True
        .Interior.ColorIndex = 2
      End With
    End If
  End If
Next ws
'********** Section 3: Supposed to Change but Didn't *********
TR = MyS3 + 2
FR = MyS3 + 3
ER = LR
For a = FR To ER Step 1
  If Not Evaluate("ISREF(" & wM.Cells(a, 1) & "!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = wM.Cells(a, 1)
  N = wM.Cells(a, 1)
  Set ws = Worksheets(N)
  MyC1 = 0
  On Error Resume Next
  MyC1 = Application.Match("Section 1: Major Change", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC1 = 0 Then
    ws.Cells.Interior.ColorIndex = 2
    wM.Range("A1:L7").Copy ws.Range("A1:L7")
    wM.Range("A1:L1").Copy
    With ws.Range("A1:L1")
      .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    ws.Range("A" & NR) = "Section Not Applicable"
    With ws.Range("A" & NR & ":L" & NR)
      .HorizontalAlignment = xlCenter
      .MergeCells = True
      .Interior.ColorIndex = 2
    End With
  End If
  MyC2 = 0
  On Error Resume Next
  MyC2 = Application.Match("Section 2: Minor Change", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC2 = 0 Then
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(2).Row
    wM.Range("A" & MyS2 & ":L" & MyS2 + 2).Copy ws.Range("A" & NR)
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    ws.Range("A" & NR) = "Section Not Applicable"
    With ws.Range("A" & NR & ":L" & NR)
      .HorizontalAlignment = xlCenter
      .MergeCells = True
      .Interior.ColorIndex = 2
    End With
  End If
  MyC3 = 0
  On Error Resume Next
  MyC3 = Application.Match("Section 3: Supposed to Change but Didn't", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC3 = 0 Then
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(2).Row
    wM.Range("A" & MyS3 & ":L" & MyS3 + 2).Copy ws.Range("A" & NR)
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  Else
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  End If
Next a
'********** Check each worksheet for "Section 3: Supposed to Change but Didn't" **********
For Each ws In ThisWorkbook.Worksheets
  If ws.Name <> "Instructions" And ws.Name <> "Master" Then
    MyC3 = 0
    On Error Resume Next
    MyC3 = Application.Match("Section 3: Supposed to Change but Didn't", ws.Columns(1), 0)
    On Error GoTo 0
    If MyC3 = 0 Then
      NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(2).Row
      wM.Range("A" & MyS3 & ":L" & MyS3 + 2).Copy ws.Range("A" & NR)
      NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      ws.Range("A" & NR) = "Section Not Applicable"
      With ws.Range("A" & NR & ":L" & NR)
        .HorizontalAlignment = xlCenter
        .MergeCells = True
        .Interior.ColorIndex = 2
      End With
    End If
  End If
Next ws
wM.Activate
Application.ScreenUpdating = True
End Sub


Then run the DistributeDataV2 macro.
 
Last edited:
Upvote 0

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
vbanewbie2011,

Glad I could help.

Thanks for the feedback.

You are very welcome.

Come back anytime.


I have been struggling with this for close to a month; your code has been a HUGE headache relief.
Click to expand...

For my own personal information: How much time in hours do you think my macro will save you per day/week/month?


I was wondering if you could recommend any books/guides that a newbie would benefit from?
Click to expand...


Training / Books / Sites

MrExcel's Products: Books, CDs, Podcasts Discuss topics related to Holy Macro! Products: Learn Excel from MrExcel, VBA and Macros for Microsoft Excel,Holy Macro! It's 2500 VBA Examples CD, Guerilla Data Analysis Using Microsoft Excel and Excel Knowledge Base CD and the MrExcel Podcasts.
http://www.mrexcel.com/forum/forumdisplay.php?f=19

How to Learn to Write Macros
http://articles.excelyogi.com/playin...ba/2008/10/27/

How to use the macro recorder
http://articles.excelyogi.com/

Click here and scroll down to Getting Started with VBA.
http://www.datapigtechnologies.com/ExcelMain.htm

If you are serious about learning VBA try
http://www.add-ins.com/vbhelp.htm

Excel Tutorials and Tips - VBA - macros - training
http://www.mrexcel.com/articles.shtml

See David McRitchie's site if you just started with VBA
http://www.mvps.org/dmcritchie/excel/getstarted.htm

What is a Visual Basic Module?
http://www.emagenit.com/VBA Folder/what_is_a_vba_module.htm

Debra Dalgleish has some notes how to implement macros here:
http://www.contextures.com/xlvba01.html

David McRitchie has an intro to macros:
http://www.mvps.org/dmcritchie/excel/getstarted.htm

Ron de Bruin's intro to macros:
http://www.rondebruin.nl/code.htm

Creating custom functions
http://office.microsoft.com/en-us/excel/HA011117011033.aspx

Writing Your First VBA Function in Excel
http://www.exceltip.com/st/Writing_Your_First_VBA_Function_in_Excel/631.html

Where to paste code in VBE VBA
Introducing the Excel VBA Editor
http://www.ask.com/web?qsrc=2417&o=101881&l=dis&q=Where+to+paste+code+in+the+Excel+VBA+Editor

VBA for Excel (Macros)
http://www.excel-vba.com/excel-vba-contents.htm

VBA Lesson 11: VBA Code General Tips and General Vocabulary
http://www.excel-vba.com/vba-code-2-1-tips.htm

Excel VBA -- Adding Code to a Workbook
http://www.contextures.com/xlvba01.html

http://www.excel-vba.com/
http://www.mvps.org/dmcritchie/excel/getstarted.htm
http://www.exceltip.com/excel_links.html

(livelessons video)
Excel VBA and Macros with MrExcel
ISBN: 0-7897-3938-0
http://www.amazon.com/Excel-Macros-M...7936479&sr=1-1

Excel Tutorials / Video Tutorials - Functions
http://www.contextures.com/xlFunctions02.html

http://www.xl-central.com/index.html

http://www.datapigtechnologies.com/ExcelMain.htm

Cascading queries

http://www.tushar-mehta.com/excel/ne...ing_dropdowns/

Excel VLOOKUP Function and VLOOKUP Example
http://www.contextures.com/xlFunctions02.html

INDEX MATCH - Excel Index Function and Excel Match Function
http://www.contextures.com/xlFunctions03.html

http://www.contextures.com/xlDataVal02.html
http://www.contextures.com/xlDataVal05.html
http://www.contextures.com/xlDataVal08.html#Larger

Excel Data Validation - Add New Items
http://www.contextures.com/excel-data-validation-add.html

Programming The VBA Editor - Created by Chip Pearson at Pearson Software Consulting LLC
This page describes how to write code that modifies or reads other VBA code.
http://www.cpearson.com/Excel/vbe.aspx

Locating files containing VBA
Searching Files in Subfolders for VBA code string:
http://www.dailydoseofexcel.com/arch...a-code-string/

http://www.pcreview.co.uk/forums/thread-978054.php

Excel 2003 Power Programming with VBA (Excel Power Programming With Vba)
by John Walkenbach

VBA and Macros for Microsoft Excel, by Bill Jelen "Mr.Excel" and Tracy Syrstad

Excel Hacks 100 Industrial-Strength Tips & Tools, by David & Traina Hawley

VBA and Macros for Microsoft Excel 2007, by Bill Jelen "Mr.Excel" and Tracy Syrstad

Excel 2007 Book: you can try this...there is a try before you buy ebook available at this link…
http://www.mrexcel.com/learnexcel2.shtml

Professional Excel Development
by Stephen/ Bovey, Rob/ Green, John Bullen (Paperback - Feb 11, 2005)

Excel 2002 VBA: Programmers Reference
by Rob Bovey, Stephen Bullen, John Green, and Robert Rosenberg (Paperback - Sep 26, 2001)

VB & VBA in a Nutshell: The Language
(http://www.amazon.co.uk/VB-VBA-Nutsh...4671189&sr=1-2)

Writing Excel Macros with VBA
(http://www.amazon.co.uk/Writing-Exce...4671189&sr=1-3)

User Form Creation
http://www.contextures.com/xlUserForm01.html

DonkeyOte: My Recommended Reading
Volatility
http://www.decisionmodels.com/calcsecretsi.htm

Sumproduct
http://www.xldynamic.com/source/xld.SUMPRODUCT.html
http://www.xldynamic.com/source/xld.SUMPRODUCT.html

Arrays
http://www.xtremevbtalk.com/showthread.php?t=296012

Pivot Intro
http://peltiertech.com/Excel/Pivots/pivotstart.htm

Sync Pivot Tables
http://www.mrexcel.com/forum/showthr...g+pivot+tables
Check out rorya's post at the very bottom of this link. It should do the trick:
http://www.experts-exchange.com/Soft..._22844558.html
Multiple pivot tables 1 filter to control all
http://www.excelforum.com/excel-prog...ntrol-all.html

Email from XL - VBA
http://www.rondebruin.nl/sendmail.htm

Outlook VBA
http://www.outlookcode.com/article.aspx?ID=40

Function Dictionary
http://www.xlfdic.com/

Function Translations
http://www.piuha.fi/excel-function-name-translation/

Dynamic Named Ranges
http://www.contextures.com/xlNames01.html

How to create Excel Dashboards
http://www.contextures.com/excel-dashboards.html
http://chandoo.org/wp/excel-dashboards/
http://chandoo.org/wp/management-dashboards-excel/
http://www.exceldashboardwidgets.com/

Excel Dashboard / Scorecard Ebook
http://www.qimacros.com/excel-dashboard-scorecard.html

Mike Alexander from Data Pig Technologies
Excel 2007 Dashboards & Reports For Dummies
 
Upvote 0
You must log in or register to reply here.

Similar threads

Z
  • Question Question
Vba - create new sheet and copy date into it.
Replies
1
Views
93
zerofeng
Z
A
  • Solved
Conditional Formatting for rows of empty cells corresponding with dates between
Replies
4
Views
506
avril18
A
K
  • Question Question
Formula needed to look up specific name and enter data from specific column within same row
Replies
1
Views
463
awoohaw
awoohaw
C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
338
NdNoviceHlp
NdNoviceHlp
T
  • Question Question
Pull data from multiple sheets that match varying criteria
Replies
1
Views
696
bobaol
B

Forum statistics

Threads
1,224,599
Messages
6,179,828
Members
452,946
Latest member
JoseDavid

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top