Working with two worksheets

[LosingMyMindAgain]

Hello. I am fairly new to Excel macros and apologize ahead of time if this is a stupid question. I am looking to work with two sheets of a workbook. I found a macro that does what I want, but only when dealing with one sheet. Sheet1 is the data entry portion and Sheet2 is where the totals will be. With this macro I am hoping to cycle through Sheet1 Column N to distinguish the unique counties listed and then count the occurrences of each county. I'd then like to paste the unique counties on Sheet2 starting at E3. Then also paste the counts on Sheet2 starting at F3. How do I go about tweaking this so I can reference back and forth between the two sheets? Any tips would be greatly appreciated. Thank you!

Sub Special_Countif()
Dim i, LastRowA, LastRowB
'A=Data Column B=Unique Names C=Count
LastRowA = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.EnableEvents = False
Columns("B:C").ClearContents
For i = 1 To LastRowA
If Application.CountIf(Range("B:B"), Cells(i, "A")) = 0 Then
Cells(i, "B").Offset(1, 0).Value = Cells(i, "A").Value
End If
Next
Columns("B:B").Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
LastRowB = Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To LastRowB
Cells(i, "C").Value = Application.CountIf(Range("A:A"), Cells(i, "B"))
Next i
Range("B1").Value = "Entry"
Range("C1").Value = "Occurrences"
Range("B1:C1").HorizontalAlignment = xlCenter
Range("B1").Select
Columns("B:C").AutoFit
Application.EnableEvents = True
End Sub

 

[hiker95]

LosingMyMindAgain,

In my last reply, I had asked for:

In order to continue please post another workbook with Sheet1, and, Sheet2, with their actual raw data, and, results (manually formatted by your) for the results you are looking for.

So that I can get it right this next time, please supply the same workbook, but, with Sheet2, range H3:I? manually completed by you for the results you are looking for.

 

[LosingMyMindAgain]

My username is becoming more and more fitting lol. https://app.box.com/s/7nhef8ziss6i9d8cem3b

 

[hiker95]

LosingMyMindAgain,

Thanks for the updated workbook.

Sample worksheets:

Excel 2007
	M	N	O
1	Service 1	County 2	State1
2	Service A	Allegheny	PA
3	Service A	Allegheny	PA
4	Service B	Beaver	PA
5	Service C	Butler	PA
6	Service C	Westmoreland	PA
7	Service C	Westmoreland	PA
8	Service C	Westmoreland	PA
9	Service C		DE
10	Service A		OH
11	Service B	Butler	PA
12
Sheet1

Excel 2007
	E	F	G	H	I
1	SERVICE			COUNTY
2
3	Service A	3
4	Service B	2
5	Service C	5
6
7
8
Sheet2

After the new macro using the Scripting.Dictionary:

Excel 2007
	E	F	G	H	I
1	SERVICE			COUNTY
2
3	Service A	3		Allegheny	2
4	Service B	2		Beaver	1
5	Service C	5		Butler	2
6				Westmoreland	3
7				Not Recorded	2
8
Sheet2

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

Sub GetUniqueCounts_V2()
' hiker95, 09/23/2014, ME807082
Dim w1 As Worksheet, w2 As Worksheet
Dim lr1 As Long, lr2 As Long, n As Long
Dim rng As Range, c As Range
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
With w2
  lr2 = .Cells(Rows.Count, "I").End(xlUp).Row
  If lr2 > 2 Then .Range("H3:I" & lr2).ClearContents
End With
With w1
  .Activate
  lr1 = .Cells(Rows.Count, "O").End(xlUp).Row
  n = Application.CountIf(.Range("N2:N" & lr1), "")
  Set rng = Range("N2:N" & lr1)
  With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each c In rng
      If Not .Exists(c.Value) Then
        .Add c.Value, 1
      Else
        .Item(c.Value) = .Item(c.Value) + 1
      End If
    Next
  w2.Range("H3").Resize(.Count, 2) = Application.Transpose(Array(.keys, .Items))
  End With
End With
With w2
  lr2 = .Cells(Rows.Count, "H").End(xlUp).Row
  If n > 0 Then
    .Cells(lr2 + 1, 8) = "Not Recorded"
  End If
  .Columns("H:I").AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

You may have to add the Microsoft Scripting Runtime to the References - VBA Project.

With your workbook that contains the above:

Press the keys ALT + F11 to open the Visual Basic Editor

In the VBA Editor, click on:
Tools
References...

Put a checkmark in the box marked
Microsoft Scripting Runtime

Then click on the OK button.

And, exit out of the VBA Editor.

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 GetUniqueCounts_V2 macro.

 

[LosingMyMindAgain]

Thanks so much Hiker! I tested it on some of our previous months workbooks where we had to manually total everything. I noticed it pulled a blank county with a count of 8 and Not Recorded had no entries. I was able to use the macro recorder to create this to sort the counties. I tried setting Range("H3:I500").Select and SetRange Range("H3:I500") to H3:I, but that didn't work. I am assuming it requires a specific end cell? I uploaded an example of what I saw on one of our older workboooks.

Sub SortCounty()'
' SortCounty Macro
'


'
Range("H3:I500").Select
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("H3"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
.SetRange Range("H3:I500")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

https://app.box.com/s/crjnmm5tkbyjsbimgk90

You have been so extremely helpful!

 

[hiker95]

LosingMyMindAgain,

I have added a sort routine to the new macro, that will sort in Sheet2, range H3:I the lastrow
by H3, ascending.


Sample raw data in worksheet Sheet1 (not all 474 rows are shown for brevit):

Excel 2007
	N	O
1	County 2	State1
2	El Oaso	CO
3	El Paso	CO
4	El Paso	CO
5	St. Augustine	FL
6	Bartow	GA
7	Anderson	IN
8	Madison	IN
9	Madison	IN
10	Madison	IN
11	Laurel	MD
12	St. Clair	MI
50	Steubenville	OH
51		OH
52		OH
53	Wagner	OK
455	York	PA
456		PA
457		PA
458		PA
459		PA
460	Morovis	PR
461	Shelby	TN
462	Shelby	TN
463	Shelby	TN
464	Shelby	TN
465	Staunton	VA
466		VA
467	Berkeley	WV
468	Elkins	WV
469	Hancock	WV
470	Marshall	WV
471	Newell	WV
472	Ohio	WV
473	Wood	WV
474		WV
475
Sheet1

Sheet2 after the new macro:

Excel 2007
	H	I
1	COUNTY
2
3	Allegheny	110
4	Anderson	1
5	Armstrong	6
6	Bartow	1
7	Beaver	34
8	Belmont	3
9	Berkeley	1
10	Blair	8
11	Blazo	1
12	Buchanan	1
13	Butler	20
14	Cambria	19
15	Charlotte	1
16	Chautauqua	1
17	Clarion	7
18	Clearfield	3
19	Crawford	12
20	Cumberland	3
21	Dauphin	1
22	El Oaso	1
23	El Paso	2
24	Elk	1
25	Elkins	1
26	Erie	13
27	Fayette	28
28	Greene	5
29	Greenville	1
30	Grove City	1
31	Hancock	1
32	Harrison	1
33	Hermitage	1
34	Huntingdon	1
35	Indiana	11
36	Jefferson	16
37	Lackawana	2
38	Lancaster	4
39	Laurel	1
40	Lawrence	12
41	Livingston	2
42	Lorraine	1
43	Luzerne	1
44	Madison	3
45	Mahoning	9
46	Marshall	1
47	Masontown	1
48	McKean	2
49	Mercer	19
50	Monroe	5
51	Morovis	1
52	Newell	1
53	Ohio	1
54	Philadelphia	2
55	Pittsburgh	1
56	Richland	1
57	Shelby	4
58	St. Augustine	1
59	St. Clair	4
60	Staunton	1
61	Steubenville	2
62	Venango	6
63	Wagner	1
64	Warren	2
65	Washington	20
66	Westmoreland	35
67	Wood	1
68	York	1
69	Not Recorded	8
70
Sheet2

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

Sub GetUniqueCounts_V3()
' hiker95, 09/24/2014, ME807082
Dim w1 As Worksheet, w2 As Worksheet
Dim lr1 As Long, lr2 As Long, n As Long
Dim rng As Range, c As Range
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
With w2
  lr2 = .Cells(Rows.Count, "I").End(xlUp).Row
  If lr2 > 2 Then .Range("H3:I" & lr2).ClearContents
End With
With w1
  .Activate
  lr1 = .Cells(Rows.Count, "O").End(xlUp).Row
  n = Application.CountIf(.Range("N2:N" & lr1), "")
  Set rng = .Range("N2:N" & lr1)
  With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each c In rng
      If Not .Exists(c.Value) Then
        .Add c.Value, 1
      Else
        .Item(c.Value) = .Item(c.Value) + 1
      End If
    Next
  w2.Range("H3").Resize(.Count, 2) = Application.Transpose(Array(.keys, .Items))
  End With
End With
With w2
  lr2 = .Cells(Rows.Count, "I").End(xlUp).Row
  .Range("H3:I" & lr2).Sort key1:=.Range("H3"), order1:=1
  If n > 0 Then
    .Cells(lr2, 8) = "Not Recorded"
  End If
  .Columns("H:I").AutoFit
  .Activate
End With
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 GetUniqueCounts_V3 macro.

 

[LosingMyMindAgain]

I apologize for the lack of response. I was ill the past few days. Hiker this is terrific! It does exactly what I need. Thank you so much for taking the time to do it!

 

[hiker95]

LosingMyMindAgain,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.

 

[LosingMyMindAgain]

Hello again! I had a follow-up to this macro. Is there a way to base it counting the counties only if the next column over lists PA?

 

[hiker95]

LosingMyMindAgain,

Is there a way to base it counting the counties only if the next column over lists PA?

I do not understand.

Can we have another workbook containing the raw data worksheets, and, the worksheet results?

 

[LosingMyMindAgain]

Hello again Hiker. You had previously created a macro for me that counted all the counties. I was hoping to track just PA counties now instead of all the state counties. We are located in PA and those are the ones we really want to keep an eye on. The spreadsheet link is below. On Sheet1 column N list the counties and column O list the state. I wanted to see if there was anyway to adjust the macro to determine and count unique N cells that had an adjacent O cell that said PA. If a N cell next to a O cell with PA didn't then maybe count is as No PA County. Is that feasible or is that too much for a macro to do? I hope that made sense. I mocked up the results on Sheet2.

https://app.box.com/s/mz0rh97qoqwsngdpy1g8