Suggestions on how to fix this Macro code?

deletedalien

Well-known Member
Joined
Dec 8, 2008
Messages
505
Office Version
  1. 2013
Platform
  1. Windows
Hi all,

i've got a macro code that i recorded and patched to help with my day to day reporting but it still has a lot of manual work, because i have to run this macro over and over and over...

I also have another macro to run whenever there is a date change in the data (you will notice this because there is no campaign right above the date and there would be another date in there...

This isnt too much manual work but when i have to run a months worth of data it gets really tedious....

So here is my code.

(i know.. it isn't much but i'm not really VBA savvy... :( )

Code:
Sub Copy_campaign()
    Selection.copy
    Selection.End(xlToLeft).Offset(2, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.End(xlUp).Select
    Selection.copy
    Range(Selection, Selection.End(xlDown).Offset(-5)).Select
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.End(xlDown).Select
    Selection.End(xlDown).Offset(-1, 2).Select
    
  'Copy Date
    
     Selection.copy
    Selection.End(xlDown).Select
    ActiveCell.Offset(rowOffset:=0, columnOffset:=-1).Activate
    Range(Selection, Selection.End(xlUp).Offset(5)).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        On Error Resume Next
        Application.CutCopyMode = False
    Selection.End(xlUp).Offset(0, 1).Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
  
       
End Sub



so in essence what i need is simple:

Add 2 columns before column "A"

move the campaign name 2 columns to the left and 2 cells down from its current location
Copy it down as many times as needed (see file)

move date 1 column to the left of the times column (times shown as 06:00 - 06:30 ) and format it as date
copy date down as many times as needed and move to the next range which could be a campaign change or date change and proceed as shown in file.
Finally stop the loop when the word "Page" is found. or just stop when there's more than 2 black cells below the data or something.

This should all make a whole lot more sense when you see my file:

https://www.dropbox.com/s/62nnokrh07j5nn4/Raw Data.xlsx?dl=0


i would highly appreciate ANY help provided with this as you would be saving me AGES worth of time (especially on month end reporting dates)
 
Last edited:

Some videos you may like

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
19,693
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
I have made some assumptions...
The Campaign names in Col "A" ARE left aligned !
AND
the dates in Col "A" are BOLD and actual dates
Code:
Sub MM1()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
For r = 3 To lr
    If Range("A" & r).Font.Bold = False And Range("A" & r).Value <> "" Then Range("F" & r).Value = Range("A" & r).Value
    If Range("A" & r).HorizontalAlignment = xlLeft And Range("A" & r).Font.Bold = True Then
        Range("D" & r).Offset(2).Value = Range("A" & r).Value
    End If
    If IsDate(Range("A" & r)) = True Then Range("E" & r).Offset(1).Value = Range("A" & r).Value
    If Range("F" & r).Value <> "" And Range("E" & r - 1).Value <> "" Then Range("E" & r).Value = Range("E" & r - 1).Value
    If Range("D" & r + 1).Value = "" Then Range("D" & r + 1).Value = Range("D" & r).Value
    If Range("F" & r).Value = "" And Range("E" & r).Value = "" Then Range("D" & r).Value = ""
Next r
End Sub
 

deletedalien

Well-known Member
Joined
Dec 8, 2008
Messages
505
Office Version
  1. 2013
Platform
  1. Windows
Im sorry but this code is not what im looking for, it doesn't insert 2 columns before Col "A" at the beginning of the code... and its actually formatting other cells.

I do appreciate you taking the time to give it a try tho :)
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
19,693
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
Well, I can insert the extra columns and mod the code if you wish
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
19,693
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows

ADVERTISEMENT

Is this closer ??
Code:
Sub MM1()
Dim lr As Long, r As Long
Columns("A:B").Insert
lr = Cells(Rows.Count, "C").End(xlUp).Row
For r = 3 To lr
    If Range("C" & r).Font.Bold = False And Range("C" & r).Value <> "" Then Range("H" & r).Value = Range("C" & r).Value
    If Range("C" & r).HorizontalAlignment = xlLeft And Range("C" & r).Font.Bold = True Then
        Range("F" & r).Offset(2).Value = Range("C" & r).Value
    End If
    If IsDate(Range("C" & r)) = True Then Range("G" & r).Offset(1).Value = Range("C" & r).Value
    If Range("H" & r).Value <> "" And Range("G" & r - 1).Value <> "" Then Range("G" & r).Value = Range("G" & r - 1).Value
    If Range("F" & r + 1).Value = "" Then Range("F" & r + 1).Value = Range("F" & r).Value
    If Range("H" & r).Value = "" And Range("G" & r).Value = "" Then Range("F" & r).Value = ""
Next r
End Sub
 

deletedalien

Well-known Member
Joined
Dec 8, 2008
Messages
505
Office Version
  1. 2013
Platform
  1. Windows
Is this closer ??
Code:
Sub MM1()
Dim lr As Long, r As Long
Columns("A:B").Insert
lr = Cells(Rows.Count, "C").End(xlUp).Row
For r = 3 To lr
    If Range("C" & r).Font.Bold = False And Range("C" & r).Value <> "" Then Range("H" & r).Value = Range("C" & r).Value
    If Range("C" & r).HorizontalAlignment = xlLeft And Range("C" & r).Font.Bold = True Then
        Range("F" & r).Offset(2).Value = Range("C" & r).Value
    End If
    If IsDate(Range("C" & r)) = True Then Range("G" & r).Offset(1).Value = Range("C" & r).Value
    If Range("H" & r).Value <> "" And Range("G" & r - 1).Value <> "" Then Range("G" & r).Value = Range("G" & r - 1).Value
    If Range("F" & r + 1).Value = "" Then Range("F" & r + 1).Value = Range("F" & r).Value
    If Range("H" & r).Value = "" And Range("G" & r).Value = "" Then Range("F" & r).Value = ""
Next r
End Sub


Yup, its closer in the sense that it has added the 2 columns before "A" but its still just formatting columns "G" and "H"

I don't mean to be a smart a55 and i really do HIGHLY appreciate your help but... did you see the file in the link? it shows what i have and what its supposed to be like.

https://www.dropbox.com/s/62nnokrh07...Data.xlsx?dl=0
 

deletedalien

Well-known Member
Joined
Dec 8, 2008
Messages
505
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

bump
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
19,693
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
Note the comment on the 2nd last line
Code:
Sub MM1()
Dim lr As Long, r As Long
Columns("A:B").Insert
lr = Cells(Rows.Count, "C").End(xlUp).Row
For r = 3 To lr
    If Range("C" & r).Font.Bold = False And Range("C" & r).Value <> "" Then Range("H" & r).Value = Range("C" & r).Value
    If IsDate(Range("C" & r)) = False And Range("C" & r).Font.Bold = True Then
        Range("F" & r).Offset(2).Value = Range("C" & r).Value
    End If
    If IsDate(Range("C" & r)) = True Then Range("G" & r).Offset(1).Value = Range("C" & r).Value
    If Range("H" & r).Value <> "" And Range("G" & r - 1).Value <> "" Then Range("G" & r).Value = Range("G" & r - 1).Value
    If Range("F" & r + 1).Value = "" Then Range("F" & r + 1).Value = Range("F" & r).Value
    If Range("H" & r).Value = "" And Range("G" & r).Value = "" Then Range("F" & r).Value = ""
Next r
    With Range("C2:C" & lr).Interior
.Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
    With Range("F2:H" & lr).Interior
.Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.399945066682943
        .PatternTintAndShade = 0
    End With
    Columns("G:G").NumberFormat = "dd/mm/yyyy" 'this may need to be modified to suit your regional settings
End Sub
 

deletedalien

Well-known Member
Joined
Dec 8, 2008
Messages
505
Office Version
  1. 2013
Platform
  1. Windows
NOW we talkin!

Thanx man i appreciate the effort :)

IT WORX!!! yessssssssss!!!!!!!!!!!
 

Watch MrExcel Video

Forum statistics

Threads
1,122,214
Messages
5,594,882
Members
413,947
Latest member
gizmolucy

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
Top