Excel “no fill”macro

thaking

New Member
Joined
Nov 12, 2013
Messages
4
I am looking for macro which will solve my issue. I have planning of machines per days, but on top of that I would like to have "overview" per machines (if there is no color fill in machine capacity planning then that means it's available for planning, otherwise is at machine planning is fill with color or text then change colour - which will mean no possible to plan)...

IT4EF.png
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
For the future, you will get many more potential helpers if you post any sample data in small copyable format so we do not have to manually type out the sample data to test. My signature block below has more help on that.

See if this is any use. Test in a copy of your workbook.
I have assumed a layout like this, per your image.
I have also assumed that all machine names in the bottom main table already appear in the top overview table.

Excel Workbook
ABCD
1day1day2day3
2machine1
3machine2
4machine3
5machine4
6
7day1day2day3
8machine1reservation1
9reservation2reservation1
10reservation3
11machine2reservation2reservation3
12reservation3reservation2reservation3
13reservation2reservation3
14machine3
15
16
17machine4
18reservation77
19
Machine Overview



Code:
Sub Machine_Overview()
  Dim a As Variant, b As Variant
  Dim lr As Long, lc As Long, r As Long, c As Long, k As Long
  Dim CurrMachine As String
  
  Const fr As Long = 7 '<- Main data header row
  
  lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  lc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
  a = Range("A" & fr, Range("A" & lr)).Resize(, lc).Value
  b = Range("A1", Range("A2").End(xlDown)).Resize(, lc).Value
  For r = 2 To UBound(a)
    If Len(a(r, 1)) > 0 Then CurrMachine = a(r, 1)
    For c = 2 To UBound(a, 2)
      If Len(a(r, c)) > 0 Then
        k = 2
        Do Until b(k, 1) = CurrMachine
          k = k + 1
        Loop
        b(k, c) = 1
      End If
    Next c
  Next r
  With Range("A1").Resize(UBound(b, 1), UBound(b, 2))
    .Value = b
    .SpecialCells(xlConstants, xlNumbers).Interior.Color = 15773696
    .SpecialCells(xlConstants, xlNumbers).ClearContents
  End With
End Sub

After the above code has been run:

Excel Workbook
ABCD
1day1day2day3
2machine1
3machine2
4machine3
5machine4
6
7day1day2day3
8machine1reservation1
9reservation2reservation1
10reservation3
11machine2reservation2reservation3
12reservation3reservation2reservation3
13reservation2reservation3
14machine3
15
16
17machine4
18reservation77
19
Machine Overview
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,185
Members
448,554
Latest member
Gleisner2

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