Macro to do numerous tasks

[Gemz]

Hi,

I posted a similar post but cannot remember the subject so couldnt re-post
there, please discard other one and see below as this is amended query:

I need a macro to do several tasks for me, i wonder if its possible..

-select columns A-E, G,H from file A, TAB 'YY' in location C:\files for
me\summary 14.2.08 (date changes all the time meaning the file name will not
remain constant)
-paste these into new workbook and call this sheet summary1 and call file
new data.
-select columns F-O, Y, Z from file B, TAB 'ZZ' in location C:\files for
me\new template\summary 14.2.08 (again date changes all the time meaning the
file name will not remain constant)
-paste these into same workbook as above but in a seperate sheet and call it
summary2
-then in sheet summary 1 when first cell in column E = 'info req' insert a
line above this and put a bold heading there called 'info req'
-again in the same sheet when first cell in column E = 'outstanding' then
insert a line above this and put a bold heading there and call it
'outstanding'.
I am doing this because the file is quite big so would like to insert
headers all the way down to divide info out -unelss there is a better way of
doing this.
-finally in summary 2 sheet, i would just like to put a filter on coulumn A
(user can pick criteria manually later) and then just colour column D blue
and all column headings Red.

Is there a way i can write all this in a macro? if steps 1 and 2 arent
possible because the filename will change and it is tab specific can i have
the other steps please?

really appreciate all your help.

 

[Joel]

Sub varoiustasks()

folder1 = "C:\files for me"
folder2 = "C:\files for me\new template"

ChDir folder1

Set Newbk = Workbooks.Add
Newbk.Sheets("Sheet1").Name = "Summary1"
Set NewbkS1 = Newbk.Sheets("Summary1")
Newbk.Sheets("Sheet2").Name = "Summary2"
Set NewbkS2 = Newbk.Sheets("Summary2")

FiletoOpen = Application _
.GetOpenFilename("Excel Files (*.xls), *.xls")

Workbooks.Open Filename:=FiletoOpen
Set oldbk = ActiveWorkbook

With oldbk.Sheets("YY")
.Columns("A:E").Copy Destination:= _
NewbkSh1.Columns("A")
.Columns("G:H").Copy Destination:= _
NewbkSh1.Columns("F")
End With

With NewbkSh1
Set C = .Columns("E").Find(what:="info req", _
LookIn:=xlvlaues, lookat:=xlWhole)
If Not C Is Nothing Then
NewRow = C.Row
Rows(NewRow).Insert
Range("E" & NewRow).Font.Bold = True
End If
Set C = .Columns("E").Find(what:="outstanding", _
LookIn:=xlvlaues, lookat:=xlWhole)
If Not C Is Nothing Then
NewRow = C.Row
Rows(NewRow).Insert
Range("E" & NewRow).Font.Bold = True
End If
End With


oldbk.Close

ChDir folder2
FiletoOpen = Application _
.GetOpenFilename("Excel Files (*.xls), *.xls")

Workbooks.Open Filename:=FiletoOpen
Set oldbk = ActiveWorkbook

With oldbk.Sheets("ZZ")
.Columns("F:O").Copy Destination:= _
NewbkSh2.Columns("A")
.Columns("Y:Z").Copy Destination:= _
NewbkSh2.Columns("K")
End With

With NewbkSh1
.Columns("A:A").AutoFilter
End With

oldbk.Close


fileSaveName = Application.GetSaveAsFilename( _
"New Data.xls", _
fileFilter:="Excel Files (*.xls), *.xls")

Newbk.SaveAs Filename:=fileSaveName

End Sub

 

[Gemz]

Hi,

Thanks so much for this code but the problem now is that the person who will
be using this code will not be able to benefit from the 'select file' bit of
the code because he doesnt havent access to the relevant folder! This means
that someone else will have to open and save the excel sheets for him so now
the macro should start from when the changes need to be made as opposed to
getting he file. I would adjust the code myself but the 'oldbk' 'newbk'
confuses me and i dont know what to change around! any help please?

thanks.

 

[Joel]

I use set statements to make statements shorter. Rather than keep on repeating

workbooks("ABC").sheets(Sheet2")

I set

set abc_bk = workbooks("ABC").sheets(Sheet2")

then use statements like

abc_bk.Range("A1") = 5

The code opens a new workbook

Set Newbk = Workbooks.Add

then at the end of the code brings up a pop up (GetSaveAsFilename) and saves
the file as shown below

fileSaveName = Application.GetSaveAsFilename( _
"New Data.xls", _
fileFilter:="Excel Files (*.xls), *.xls")

Newbk.SaveAs Filename:=fileSaveName

oldbk get set to two differrent files. First pop up (GetOpenFilename)

FiletoOpen = Application _
.GetOpenFilename("Excel Files (*.xls), *.xls")

Workbooks.Open Filename:=FiletoOpen
Set oldbk = ActiveWorkbook

Then the code is repeated for the second pop up. Notice the chdir sets the
folder to the location of the 2nd file.

ChDir folder2
FiletoOpen = Application _
.GetOpenFilename("Excel Files (*.xls), *.xls")

Workbooks.Open Filename:=FiletoOpen
Set oldbk = ActiveWorkbook


I can't solve the problem with the person who is running the code not having
access to the files.

 

[Gemz]

Hi,

I understand it abit better now thanks and i know you are unable to do
anything about a person not having access.. what i meant was i wanted to
change the code so that they dont have the option to open a file anymore seen
as they wont be able to do it anyway. So, what i have done in the below code
is take that bit out where it gives the user the option to search a file (now
somebody else will compile the info required and the macro can work from then
on). I have added some modification but find it is still playing up.. the
filter h:h bit keeps throwing up an error and couple of other lines later
too..

please can you check the code to see for any problems or something that isnt
stated corectly which stops it from functioning properly?

Sub Macro3()
Set Newbk = Workbooks.Add
Newbk.Sheets("Sheet1").Name = "Track"
Set NewbkS1 = Newbk.Sheets("Track")
Newbk.Sheets("Sheet2").Name = "Outstanding"
Set NewbkS2 = Newbk.Sheets("Outstanding")
Set oldbk = ActiveWorkbook
With oldbksh2
Cells.Select
.Columns("H:H").AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="D&T"

End With
With oldbk.Sheets("PC")
.Columns("C:F").Copy Destination:= _
NewbkSh1.Columns("A")
.Columns("K:Q").Copy Destination:= _
NewbkSh1.Columns("E")
End With
With NewbkSh1
Set C = .Columns("R").Find(what:="info req", _
LookIn:=xlvlaues, lookat:=xlWhole)
If Not C Is Nothing Then
NewRow = C.Row
Rows(NewRow).Insert
Range("R" & NewRow).Font.Bold = True
End If
Set C = .Columns("R").Find(what:="outstandingArt", _
LookIn:=xlvlaues, lookat:=xlWhole)
If Not C Is Nothing Then
NewRow = C.Row
Rows(NewRow).Insert
Range("R" & NewRow).Font.Bold = True
End If
End With
Set oldbk = ActiveWorkbook
With oldbk.Sheets("D Track")
.Columns("H,T,AK,G,AJ,D,AM,AP,U,V,AQ").Copy Destination:= _
NewbkSh2.Columns("A")
End With
With NewbkSh2
.Columns("A:A").AutoFilter
End With
oldbk.Close
End Sub

Also,
-Is there a way to change the bit: Rows(NewRow).Insert
Range("R" & NewRow).Font.Bold = True
So that it doesnt actually change the word into bold and heading type when
it finds it but re-types the word and inserts that word in the new row as a
heading even if its half way down the page (still would like a heading type
of insertion here,if poss.)

- i would also like to add 'newbksh2 row 1 colour=red and row 3 colour
=blue'. but dont know how to put it in..

Thanks a lot.

 

[Joel]

This line is wrong
from
With oldbksh2
Cells.Select
.Columns("H:H").AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="D&T"

End With
to
With oldbk.sheets("Sheet2")
.Columns("H:H").AutoFilter
.cells.AutoFilter Field:=1, Criteria1:="D&T"

End With

to change the headings
from
If Not C Is Nothing Then
NewRow = C.Row
Rows(NewRow).Insert
Range("R" & NewRow).Font.Bold = True
End If
to
If Not C Is Nothing Then
NewRow = C.Row
Rows(NewRow).Insert
Range("R" & NewRow) = "info req"
Range("R" & (NewRow + 1)) = ""
Range("R" & NewRow).Font.Bold = True
End If

Note: NewRow is the rownumber of the blank row


colors red = 3 and blue = 5
Rows("1:1").Interior.ColorIndex = 3
Rows("3:3").Interior.ColorIndex = 5

 

[Gemz]

I cant get any further than the line below with the code because it keeps
reporting error and highlights the line:

With oldbk.Sheets("sheet2")
.Columns("H:H").AutoFilter
.Cells.AutoFilter Field:=1, Criteria1:="D&T"

I have changed "sheet2" to the name of the sheet that i want the filter to
be applied to but no luck..

any suggestions? thanks.

 

[Gemz]

I have fixed the below problem now, but have stumbled across something else:

The below bit of my code works fine until it starts to look at the oldbk for
sheet2. i dont understand why but it copies into sheet one absolutely fine
and without reporting an error or anything the macro finishes running and
when i look into sheet 2 to see if the data is there but the sheet has been
named accordingly but it doesnt contain any data - its empty! why is that?

also, are you able to kinldy insert a code to autofit columns.. i know how
to say it 'columns.autofit' but always have trouble inserting into code as i
get order incorrect!

Also, the sheet this code comes from will go to will always grow my 1
columns every so often, is there a statement u can put in the code that will
pick up everytime a new column is inserted. For example,
'.Columns("K:AF").Copy Destination:= _' will grow to AG soon.. the macro has
been told to copy until AF but that is only true for now. How can i tell
macro to copy until last non-empty column so it can pick up all info it
should even though the macro has been specified to copy info till AF.

Hope im making sense!! thanks so much.

With oldbk.Sheets(1)
.AutoFilterMode = False

'Cells.Select
.Columns("H:H").AutoFilter Field:=1, Criteria1:="DBT"
.Columns("C:F").Copy Destination:= _
NewbkS1.Range("A1")
.Columns("K:AF").Copy Destination:= _
NewbkS1.Range("E1")

End With

Set oldbk = ActiveWorkbook

With oldbk.Sheets(2)
.AutoFilterMode = False

.Columns("C:F").Copy Destination:= _
NewbkS2.Range("A1")
.Columns("K:AF").Copy Destination:= _
NewbkS2.Range("E1")
End With


End Sub
thanks.

 

[Joel]

I wouldn't use tab numbers (1) to indicate the sheet, instead use actual
names ("sheet1" or equivalent). the tab number indicates the left most sheet
in the worksheet. You can easily move the sheet to another position in the
work book and the tab number will change. , but the name will stay the same.

Check to make sure the columns you are co.pying have data in them. Also
check the Newworkbook to see if the data is in the new book, not the old.

This stteyment does nothing, it can be removed
'Cells.Select

to get the last column use this code
last column = .cells(1,columns.count).end(xltoleft).column
firstcolumn = .range("K1").column
.Columns(firstcolumn & ":" & lastcolumn).Copy Destination:= _
NewbkS1.Range("E1")

 

[Gemz]

Hi,

thanks for getting back, i inserted the 'last line' code as below:

.Columns("H:H").AutoFilter Field:=1, Criteria1:="DBT"

Last Column = .Cells(1, Columns.Count).End(xlToLeft).Column
firstcolumn = .Range("K1").Column
.Columns(firstcolumn & "c:f" & lastcolumn).Copy Destination:= _
NewbkS1.Range("E1")

but it just highlights the word 'last' and doesnt do anything. what if i
wanted to enter more columns to copy could i just continue with ":"? also i
dont understand how am i supposed to put in how i did before, the syntax is
slightly different.. i think the k1 above might represent K:AF below but what
about the C:F, is it correct how i put it above?

..Columns("C:F").Copy Destination:= _
NewbkS1.Range("A1")
.Columns("K:AF").Copy Destination:= _
NewbkS1.Range("E1")


thanks a lot!

 

[Gemz]

Hi,

Sorry, missed out the below:
I have doubled checked and the old book does contain the data in the
specified cells, it also is named correctly in the code so i dont know why
the code below returnd nothing..

The code is saying copy the specified columns from oldbk to newbk right?
Then i dont know whats wrong because the oldbk does contain all the data
below, might it be something to do with active.workbook?

With oldbk.Sheets("sheet2")
.Columns("H:H", "T:T", "AK:AK", "G:G", "AJ:AJ", "D", "AM:AM", "AP:AP",
"U:U", "V:V", ":AQ:AQ").Copy Destination:= _
NewbkSh2.Columns("A")
End With

 

[Joel]

LastColumn has a space that needs to be removed.

You are copying the filtered columns. Maybe there is no data in the filter?

I get an error with Excel 2003 on my computer with the copy line. Use Range
instead of columns and remove the double-qutoes as shown below

.Range("H:H, T:T, AK:AK, G:G, AJ:AJ, D, AM:AM, AP:AP, U:U, V:V,
AQ:AQ").Copy _
Destination:=NewbkSh2.Columns("A")

 

[Gemz]

Hi,

I am sorry to keep bothering you about this code but i am really having no
luck and need this sorted as a matter of urgency and i just cant seem to make
it work. below is my full code alongside comments about what is going wrong.
please can you have a glance and put me in the right direction? if u want to
see my spreadsheet i am happy to email u it.

Sub Macro3()

Set oldbk = ActiveWorkbook
Set newbk = Workbooks.Add
newbk.Sheets("Sheet1").Name = "Track"
Set NewbkS1 = newbk.Sheets("Track")
If newbk.Sheets.Count > 1 Then
newbk.Sheets("Sheet2").Name = "Outstanding"
Else
newbk.Sheets.Add after:=Sheets(1)
newbk.Sheets("Sheet2").Name = "Outstanding"
End If
Set NewbkS2 = newbk.Sheets("Outstanding")

With oldbk.Sheets(1)
.AutoFilterMode = False

'this is your code and i want it to take info from the bit below.. it doesnt
work at the mo..i'd also like these autofitted..
'last column = .cells(1,columns.count).end(xltoleft).column
' firstcolumn = .range("K1").column
' .Columns(firstcolumn & ":" & lastcolumn).Copy Destination:= _
' NewbkS1.Range("E1")

.Columns("H:H").AutoFilter Field:=1, Criteria1:="DBT"
.Columns("C:F").Copy Destination:= _
NewbkS1.Range("A1")
.Columns("K:Q").Copy Destination:= _
NewbkS1.Range("E1")
End With

'this doesnt find anything..

With NewbkS1
Set C = .Columns("R").Find(what:="DBT", _
LookIn:=xlvlaues, lookat:=xlWhole)
If Not C Is Nothing Then
NewRow = C.Row
Rows(NewRow).Insert
Range("R" & NewRow).Font.Bold = True
End If
Set C = .Columns("R").Find(what:="DBT Architecture", _
LookIn:=xlvlaues, lookat:=xlWhole)
If Not C Is Nothing Then
NewRow = C.Row
Rows(NewRow).Insert
Range("R" & NewRow).Font.Bold = True
End If
End With

Set oldbk = ActiveWorkbook

'this doesnt copy anything

With oldbk.Sheets("Track2")
.Range("H:H, T:T, AK:AK, G:G, AJ:AJ, D, AM:AM, AP:AP, U:U, V:V,
AQ:AQ").Copy _
Destination:=NewbkSh2.Columns("A")
End With

With NewbkSh2
.Columns("A:A").AutoFilter
End With

oldbk.Close

End Sub