Correction in code to re arrange dat

[ANTONIO1981]

HI All

the result of the of the macro is in tab Capitalisation

Below macro filters the right data in Site_assumptions and arranges into Capitalisation tab

Example

AT2 Krottenbach Jul-71 New sites Nov-17


However i need to add in column F "Engineers" and "Site finders" per site and i don't know how to write that


Hence as an example of site AT2, it has to look like :

AT2 Krottenbach Jul-71 New sites Nov-17 Engineers
AT2 Krottenbach Jul-71 New sites Nov-17 Site finders


I have below code but is only working well for site AT2 , the rest of sites don't add Engineers and site finders

(attached) CAPITALISATION.xlsb - Google Drive

Sub CAPITALISATION(): Dim r As Long


'Application.ScreenUpdating = False
    Sheets("CAPITALISATION").Cells(1).CurrentRegion.Offset(1).ClearContents
    'the current region only works if the columns and rows next to it are blank
   With Sheets("SITE_ASSUMPTIONS").Range("p9").CurrentRegion
        .Parent.AutoFilterMode = False
        ' colum to filter is 4
        '7 is part of the formula is always 7
        .AutoFilter 4, Array("Renovation", "New sites"), 7
        .Copy Sheets("CAPITALISATION").Cells(1)
        .AutoFilter
    End With
    With Sheets("CAPITALISATION"): r = 2
    Do Until .Range("D" & r).Value = ""
    If .Range("D" & r).Value = "New sites" Then
    .Range("A" & r).Resize(1, 5).Copy: .Rows(r + 1).Insert
    .Range("F" & r).Value = "Engineers": r = r + 1
    .Range("F" & r).Value = "site finders"
    End If: r = r + 1: Loop
    End With
    Application.CutCopyMode = False
End Sub
[COLOR=#333333]

[/COLOR]

thanks in advance

AC

 

[MickG]

Perhaps this:-

Sub CAPITALISATION():
Dim Lst As Long, n As Long
'Application.ScreenUpdating = False
    Sheets("CAPITALISATION").Cells(1).CurrentRegion.Offset(1).ClearContents
    'the current region only works if the columns and rows next to it are blank
   With Sheets("SITE_ASSUMPTIONS").Range("p9").CurrentRegion
        .Parent.AutoFilterMode = False
        ' colum to filter is 4
        '7 is part of the formula is always 7
        .AutoFilter 4, Array("Renovation", "New sites"), 7
        .Copy Sheets("CAPITALISATION").Cells(1)
        .AutoFilter
    End With
 With Sheets("CAPITALISATION")
  Lst = .Range("A" & Rows.Count).End(xlUp).Row
    For n = Lst To 2 Step -1
      With .Range("F" & n)
          .EntireRow.Copy
          .Offset(1).EntireRow.Insert
          .Resize(2).Value = Application.Transpose(Array("Engineers", "Site finders"))
     End With
     Next n
End With
End Sub

 

[ANTONIO1981]

HI

Many thanks it works the only thing is that once macro finishes , it lefts selected row 2 in tab capitalisation

thanks in advance

ac

 

[MickG]

You need to add this to bottom of code .

Application.CutCopyMode = False

Try this for your latest query !!!!

[COLOR="Navy"]Sub[/COLOR] MG27Aug49
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, t
  t = Timer
  Ray = Sheets("SITE_ASSUMPTIONS").Range("p9").CurrentRegion
    ReDim nray(1 To UBound(Ray, 1) * 2, 1 To 6)
        [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
            [COLOR="Navy"]If[/COLOR] Ray(n, 4) = "New sites" Or Ray(n, 4) = "Renovation" [COLOR="Navy"]Then[/COLOR]
                c = c + 1
                [COLOR="Navy"]For[/COLOR] Ac = 1 To 5
                     nray(c, Ac) = Ray(n, Ac)
                     nray(c, 6) = "Engineers"
                  [COLOR="Navy"]Next[/COLOR] Ac
                  c = c + 1
                  [COLOR="Navy"]For[/COLOR] Ac = 1 To 5
                    nray(c, Ac) = Ray(n, Ac)
                    nray(c, 6) = "Site Finders"
                [COLOR="Navy"]Next[/COLOR] Ac
            [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]With[/COLOR] Sheets("CAPITALISATION")
    .Cells(1).CurrentRegion.Offset(1).ClearContents
    .Range("A2").Resize(c, 6) = nray
[COLOR="Navy"]End[/COLOR] With
MsgBox Timer - t
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[ANTONIO1981]

just perfect!! very fast and nice

 

[MickG]

You're welcome