Macro for left fill in dat

[Kevw1]

Hi can anyone help please?

I am trying to create a macro to auto fill cells to the left, based on another cells population. I have a macro that fills to the right, but can not get it to fill to the left, still relatively new to VBA.

I am creating a forecast for resources, the only known value is the milestone the project has reached. I have a table with Project in the rows and Month in the columns. The table then has the Milestone identified against the Project and month delivered e.g.

[TABLE="width: 474"]
<colgroup><col span="6"></colgroup><tbody>[TR]
[TD] [/TD]
[TD]Jan-18[/TD]
[TD]Feb-18[/TD]
[TD]Mar-18[/TD]
[TD]Apr-18[/TD]
[TD]May-18[/TD]
[/TR]
[TR]
[TD]Project 1[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Milestone 3[/TD]
[/TR]
[TR]
[TD]Project 2[/TD]
[TD] [/TD]
[TD]Milestone 1[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Milestone 2[/TD]
[/TR]
[TR]
[TD]Project 3[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Milestone 2[/TD]
[TD] [/TD]
[TD]Milestone 5[/TD]
[/TR]
</tbody>[/TABLE]

There is a changing number of projects but will be around 100-200 and this will span multiple years 10+, hence needs to keep running until it has got to the end of the table.

I currently have a table with all this data in on a tab called "Monthly View" and this data is pasted in to a new tab called "Macro" in excel which is where the Macro runs.

I need to be able to use the populated Milestone and fill the cells to the Left, until it hits the next Milestone. When the fill reaches the first Milestone "Project Start" it must stop likewise when it sees the last milestone "Project Finish" there will be no further Milestones. Not all milestones will be available so will have to account for this also. e.g.

[TABLE="width: 474"]
<tbody style="background-attachment: scroll; background-clip: border-box; background-color: transparent; background-image: none; background-origin: padding-box; background-position-x: 0%; background-position-y: 0%; background-repeat: repeat; background-size: auto; color: rgb(34, 34, 34); font-family: Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif; font-size: 13px; font-size-adjust: none; font-stretch: normal; font-style: normal; font-variant: normal; font-weight: 400; line-height: normal; margin-bottom: 0px; margin-left: 0px; margin-right: 0px; margin-top: 0px; padding-bottom: 0px; padding-left: 0px; padding-right: 0px; padding-top: 0px;">[TR="bgcolor: transparent"]
[TD][/TD]
[TD]Jan-18[/TD]
[TD]Feb-18[/TD]
[TD]Mar-18[/TD]
[TD]Apr-18[/TD]
[TD]May-18[/TD]
[/TR]
[TR="bgcolor: transparent"]
[TD]Project 1[/TD]
[TD="bgcolor: transparent"]

Milestone 3​

[/TD]
[TD="bgcolor: transparent"]

Milestone 3​

[/TD]
[TD="bgcolor: transparent"]

Milestone 3​

[/TD]
[TD="bgcolor: transparent"]

Milestone 3​

[/TD]
[TD="bgcolor: transparent"]Milestone 3[/TD]
[/TR]
[TR="bgcolor: transparent"]
[TD]Project 2[/TD]
[TD="bgcolor: transparent"]

Milestone 1​

[/TD]
[TD="bgcolor: transparent"]Milestone 1[/TD]
[TD="bgcolor: transparent"]

Milestone 2​

[/TD]
[TD="bgcolor: transparent"]

Milestone 2​

[/TD]
[TD="bgcolor: transparent"]Milestone 2[/TD]
[/TR]
[TR="bgcolor: transparent"]
[TD]Project 3[/TD]
[TD="bgcolor: transparent"]

Milestone 2​

[/TD]
[TD="bgcolor: transparent"]

Milestone 2​

[/TD]
[TD="bgcolor: transparent"]Milestone 2[/TD]
[TD="bgcolor: transparent"]

Milestone 5​

[/TD]
[TD="bgcolor: transparent"]Milestone 5[/TD]
[/TR]
</tbody>[/TABLE]

Thanks for any help that can be provided.

 

[Fluff]

How about

Sub FillBlanks()

   With Sheets("Macro").UsedRange.Offset(1)
      .SpecialCells(xlBlanks).FormulaR1C1 = "=rc[1]"
      .Value = .Value
   End With
End Sub

 

[hiker95]

Kevw1,

Here is a macro solution for you to consider, that is based on your flat text display, and, will run in the ActiveSheet.

Sub FillBlanksFromRight()
' hiker95, 03/15/2018, ME1047721
Dim lr As Long, lc As Long
With ActiveSheet
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  With .Range(.Cells(2, 1), .Cells(lr, lc))
    .SpecialCells(xlBlanks).FormulaR1C1 = "=rc[1]"
    .Value = .Value
  End With
  .UsedRange.Columns.AutoFit
End With
End Sub

 

[hiker95]

Kevw1,

Here is another macro solution for you to consider, that is based on your flat text display, and, will run in the Macro worksheet.

Sub FillBlanksFromRight_V2()
' hiker95, 03/15/2018, ME1047721
Dim lr As Long, lc As Long
With Sheets("Macro")
  lr = .UsedRange.Rows.Count
  lc = .UsedRange.Columns.Count
  With .Range(.Cells(2, 1), .Cells(lr, lc))
    .SpecialCells(xlBlanks).FormulaR1C1 = "=rc[1]"
    .Value = .Value
  End With
  .UsedRange.Columns.AutoFit
End With
End Sub

 

[Kevw1]

Hi, Thanks for the suggestions, with the first code this does not seam to be working for some reason.

The second code this works better, in that it is pasting some values to the left. But is also pasting values which are not there too. I will try and upload the file to show what is happening.

thanks for your help.

 

[Kevw1]

Hi, Please find link to a drop box with example data in it

https://www.dropbox.com/s/kj4gqz8ux0adtdo/Resource Forecast.xlsm?dl=0

With the file I copy and paste values in to the raw data tab, then use formula in the monthly view tab to copy the dates. From that my current macro copies the data and pastes in to the macro tab, where it runs the fill right. the current code is as follows but now needs to fill left and I can not get it to work for some reason.

Sub Milestones()
Application.ScreenUpdating = False
Sheets("Monthly view").Visible = True
Sheets("Macro").Visible = True
Sheets("Monthly view").Select
Range("N2:IG300").Select
Selection.Copy
Sheets("Macro").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim UsdRws As Long
Dim DataRng As Range
Dim Cl As Range
Dim Rng As Range

UsdRws = Range("A" & Rows.Count).End(xlUp).Row
Set DataRng = Range("B2:HU" & UsdRws)
With DataRng
.Value = .Value
End With

For Each Rng In Range("B2:B" & UsdRws)
If Len(Rng) = 0 And Not Rng.End(xlToRight) = "0-MDT" Then
If WorksheetFunction.CountA(DataRng.Rows(Rng.Row - 1)) > 0 Then
Range(Rng, Rng.End(xlToRight)).FillLeft
End If
End If
Next Rng
On Error Resume Next
DataRng.Columns(1).SpecialCells(xlBlanks).Value = "X"
On Error GoTo 0
With DataRng.Offset(, 1).Resize(, DataRng.Columns.Count - 1)
On Error Resume Next
.SpecialCells(xlBlanks).FormulaR1C1 = "=rc[-1]"
On Error GoTo 0
.Value = .Value
End With
DataRng.Replace "X", "", xlWhole, , , , False, False
Sheets("Monthly view").Visible = False
Sheets("Macro").Visible = False
Application.ScreenUpdating = True
End Sub

 

[Kevw1]

sorry last link broke, https://www.dropbox.com/s/kgr948uzp8cxox3/Resource Forecast.xlsx?dl=0 this is the new one

 

[Fluff]

Ok try this

Sub FillBlanks()

   With Sheets("Macro").UsedRange.Offset(1)
      .Value = .Value
      .SpecialCells(xlBlanks).FormulaR1C1 = "=rc[1]"
      .Value = .Value
   End With
End Sub

 

[Kevw1]

Hi Fluff, thanks, So filling to the left OK now, but the code is still running before and after the first and last milestones. There are 13 Milestones in total which are identified in the tab "Monthly view" in the range "B2:N2", you helped me with the last Macro thanks by the way for that too.

 

[Fluff]

Is this what you need?

Sub FillBlanks()

   With Sheets("Macro").UsedRange.Offset(1)
      .Value = .Value
      .SpecialCells(xlBlanks).FormulaR1C1 = "=if(rc[1]="""","""",if(left(rc[1],2)=""0 "","""",rc[1]))"
      .Value = .Value
   End With
End Sub