T
The Rookie
Hi everybody,
I've got a VB-Excel macro which help me to track some data from 5
differents tables and paste them in a final sheet I use on a basis each
week (see the code below), my problem is that the macro search data by
columns and past them by columns, what i want is to be able to past the
data I need by row.
Is it possible? Probably but after 24h of try I can make the right
correction.
Thanks for your help..........
Public Start_Row As String
Public End_Row_C As Integer
Public End_Row_M As Integer
Public End_Column_Num As Integer
Public Current_Week As Integer
'
Public Column_Customer As Integer
Public Column_Sector_SMB As Integer
Public Column_Business_Partner As Integer
Public Column_Brand As Integer
Public Column_GRMG As Integer
Public Column_Vol_GBP As Integer
Public Column_Vol_USD As Integer
Public Column_FSE As Integer
Public Column_ITSR As Integer
Public Column_Comments As Integer
Public Column_Last_action As Integer
Public Column_Next_Follow_Up As Integer
Public Column_Source As Integer
Public Column_Forecast As Integer
Public Column_GF_ODDS As Integer
Public Column_IBM_ODDS As Integer
Public Column_ROCK As Integer
Public Column_F_RISK As Integer
Public Column_BCD As Integer
Public Column_NIF As Integer
Public Column_ASSESS As Integer
Public Column_QVF As Integer
Public Column_QV As Integer
'
Public Spreadsheet_Name As String
Sub Forcast_Add_Data(File_Name As String)
'
' This macro adds cells from the spreadsheets in the file list
'
' Open the spreadsheet
'
'
' First find where we should insert the new test in the Master
'
Windows(Spreadsheet_Name).Activate
Sheets("Master").Select
Row_Count_M = Val(Start_Row)
Field1 = "****"
Field2 = "****"
'
Do While Field1 <> "" Or Field2 <> ""
CellPointer = "A" + LTrim(Str(Row_Count_M))
Range(CellPointer).Select
Field1 = ActiveCell.FormulaR1C1
CellPointer = "A" + LTrim(Str(Row_Count_M + 1))
Range(CellPointer).Select
Field2 = ActiveCell.FormulaR1C1
Row_Count_M = Row_Count_M + 1
Loop
'
' Row_Count_M now points at the first blank row + 1. Move back to
1st
' blank row.
'
Row_Count_M = Row_Count_M - 1
'
Workbooks.Open Filename:=File_Name, UpdateLinks:=0
Workbook_Name = ActiveWorkbook.Name
Windows(Workbook_Name).Activate
Sheets(1).Select
'
' Validate that the headings agree with the master ones
'
Validate_Flag = 1
Cells(Start_Row - 1, Column_Customer).Select
If UCase(ActiveCell.FormulaR1C1) <> "CUSTOMER" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Sector_SMB).Select
If UCase(ActiveCell.FormulaR1C1) <> "SECTOR/SMB" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Business_Partner).Select
If UCase(ActiveCell.FormulaR1C1) <> "BUSINESS PARTNER" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Brand).Select
If UCase(ActiveCell.FormulaR1C1) <> "BRAND" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Vol_GBP).Select
If UCase(ActiveCell.FormulaR1C1) <> "VOL (GBP) / £K" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Vol_USD).Select
If UCase(ActiveCell.FormulaR1C1) <> "VOL (USD) / $K" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Comments).Select
If UCase(ActiveCell.FormulaR1C1) <> "COMMENTS" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Last_action).Select
If UCase(ActiveCell.FormulaR1C1) <> "LAST ACTION" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Next_Follow_Up).Select
If UCase(ActiveCell.FormulaR1C1) <> "NEXT FOLLOW UP" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Source).Select
If UCase(ActiveCell.FormulaR1C1) <> "SOURCE" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Forecast).Select
If UCase(ActiveCell.FormulaR1C1) <> "FORECAST" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_GF_ODDS).Select
If UCase(ActiveCell.FormulaR1C1) <> "GF ODDS" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_IBM_ODDS).Select
If UCase(ActiveCell.FormulaR1C1) <> "IBM ODDS" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_ROCK).Select
If UCase(ActiveCell.FormulaR1C1) <> "ROCK" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_F_RISK).Select
If UCase(ActiveCell.FormulaR1C1) <> "F/RISK" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_BCD).Select
If UCase(ActiveCell.FormulaR1C1) <> "BCD" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_NIF).Select
If UCase(ActiveCell.FormulaR1C1) <> "NIF" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_ASSESS).Select
If UCase(ActiveCell.FormulaR1C1) <> "ASSESS" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_QVF).Select
If UCase(ActiveCell.FormulaR1C1) <> "QVF" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_QV).Select
If UCase(ActiveCell.FormulaR1C1) <> "QV" Then
Validate_Flag = 0
End If
If Validate_Flag <> 1 Then
MsgBox "Headings on detail spreadsheet do not match, results
may be wrong."
End If
'
Sheets(1).Select
Selection.ClearOutline
'
' Save values from C3 and C4
'
Range("C3").Select
Manager = ActiveCell.FormulaR1C1
'
' Find last row completed
'
Row_Count = Val(Start_Row)
Field1 = "****"
Field2 = "****"
'
Do While Field1 <> "" Or Field2 <> ""
CellPointer = "A" + LTrim(Str(Row_Count))
Range(CellPointer).Select
Field1 = ActiveCell.FormulaR1C1
CellPointer = "A" + LTrim(Str(Row_Count + 1))
Range(CellPointer).Select
Field2 = ActiveCell.FormulaR1C1
' Now clear validation from all columns
'
Range(Cells(Row_Count, 1), Cells(Row_Count,
End_Column_Num)).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly,
AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
Row_Count = Row_Count + 1
Loop
Row_Count = Row_Count - 1
Range(Cells(Val(Start_Row), 1), Cells(Row_Count - 1,
End_Column_Num)).Select
Selection.Copy
Windows(Spreadsheet_Name).Activate
Sheets("Master").Select
CellPointer = "A" + LTrim(Str(Row_Count_M))
Range(CellPointer).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteComments, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Selection.Copy
Windows(Workbook_Name).Activate
ActiveWindow.Close SaveChanges:=False
Windows(Spreadsheet_Name).Activate
Sheets("Master").Select
End Sub
Sub Forcast_Get_Input()
'
' Get list of files in directory C:\Documents and
Settings\gb011477\IFSE\My Documents\2006 Forcasts
' For each file found call macro Forcast_Add_Data to add data
' to master spreadsheet. Do not call Forcast_Add_Data for the master
yup
' spreadsheet itself.
'
'
' Prompt for Start Row and End Column
'
Start_Row = InputBox("Please enter the start row for data", "Enter
Start Row", "8")
'
'Prompt to include Slip/Lost rows
'
' Get spreadsheet name
'
Spreadsheet_Name = ActiveWorkbook.Name
'
' Look through columns and find column numbers for key columns
'
Sheets("Master").Select
'
Column_Customer = 0
Column_Sector_SMB = 0
Column_Business_Partner = 0
Column_Brand = 0
Column_Vol_GBP = 0
Column_Vol_USD = 0
Column_FSE = 0
Column_ITSR = 0
Column_Comments = 0
Column_GRMG = 0
Column_Last_action = 0
Column_Next_Follow_Up = 0
Column_Source = 0
Column_Forecast = 0
Column_GF_ODDS = 0
Column_IBM_ODDS = 0
Column_ROCK = 0
Column_F_RISK = 0
Column_BCD = 0
Column_NIF = 0
Column_ASSESS = 0
Column_QVF = 0
Column_QV = 0
Column_Count = 1
Do While Column_Count <= 99
Cells(Start_Row - 1, Column_Count).Select
If ActiveCell.FormulaR1C1 = "" Then ' reached end of
columns with data
Column_Count = 100
Else
Select Case UCase(ActiveCell.FormulaR1C1) ' Evaluate
CellContents
Case "CUSTOMER"
Column_Customer = Column_Count
Case "SECTOR/SMB"
Column_Sector_SMB = Column_Count
Case "BUSINESS PARTNER"
Column_Business_Partner = Column_Count
Case "BRAND"
Column_Brand = Column_Count
Case "VOL (GBP) / £K"
Column_Vol_GBP = Column_Count
Case "VOL (USD) / $K"
Column_Vol_USD = Column_Count
Case "FSE"
Column_FSE = Column_Count
Case "ITSR"
Column_ITSR = Column_Count
Case "COMMENTS"
Column_Comments = Column_Count
Case "GRMG"
Column_GRMG = Column_Count
Case "LAST ACTION"
Column_Last_action = Column_Count
Case "NEXT FOLLOW UP"
Column_Next_Follow_Up = Column_Count
Case "SOURCE"
Column_Source = Column_Count
Case "FORECAST"
Column_Forecast = Column_Count
Case "GF ODDS"
Column_GF_ODDS = Column_Count
Case "IBM ODDS"
Column_IBM_ODDS = Column_Count
Case "ROCK"
Column_ROCK = Column_Count
Case "F/RISK"
Column_F_RISK = Column_Count
Case "BCD"
Column_BCD = Column_Count
Case "NIF"
Column_NIF = Column_Count
Case "ASSESS"
Column_ASSESS = Column_Count
Case "QVF"
Column_QVF = Column_Count
Case "QV"
Column_QV = Column_Count
End Select
End If
Column_Count = Column_Count + 1
Loop
'
' Check that every column was found
'
If Column_Customer = 0 Or _
Column_Sector_SMB = 0 Or _
Column_Business_Partner = 0 Or _
Column_Brand = 0 Or _
Column_Vol_GBP = 0 Or _
Column_Vol_USD = 0 Or _
Column_FSE = 0 Or _
Column_ITSR = 0 Or _
Column_Comments = 0 Or _
Column_GRMG = 0 Or _
Column_Last_action = 0 Or _
Column_Next_Follow_Up = 0 Or _
Column_Source = 0 Or _
Column_Forecast = 0 Or _
Column_GF_ODDS = 0 Or _
Column_IBM_ODDS = 0 Or _
Column_ROCK = 0 Or _
Column_F_RISK = 0 Or _
Column_BCD = 0 Or _
Column_NIF = 0 Or _
Column_ASSESS = 0 Or _
Column_QVF = 0 Or _
Column_QV = 0 Then
Application.WindowState = xlNormal
DummyText = MsgBox("Cannot find all columns", vbOKCancel)
GoTo ExitLabel
End If
End_Column_Num = Column_QV
Sheets("Control").Select
'
' Loop through all files in directory
'
Set fs = Application.FileSearch
With fs
.LookIn = "C:\$User\2006 Forecasts"
.Filename = "*.xls"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
For I = 1 To .FoundFiles.Count
If InStr(.FoundFiles(I), Spreadsheet_Name) = 0 Then
Forcast_Add_Data .FoundFiles(I)
End If
Next I
Else
MsgBox "There were no files found."
GoTo ExitLabel
End If
End With
'
' Now tidy up resulting spreadsheet
'
Row_Count_M = Val(Start_Row)
Field1 = "****"
Field2 = "****"
Field1A = "****"
'
Do While Field1 <> "" Or Field2 <> ""
Cells(Row_Count_M, Column_Customer).Select ' Customer
Field1 = ActiveCell.FormulaR1C1
Cells(Row_Count_M, Column_Vol_GBP).Select ' Value
Field1A = ActiveCell.FormulaR1C1
Cells(Row_Count_M + 1, Column_Customer).Select
Field2 = ActiveCell.FormulaR1C1
'
' Clear out any blank rows and also old slip rows if
parameter set
'
If Trim(Field1) = "" And Trim(Field1A) = "" And
Trim(Field2) <> "" Then
CellPointer = LTrim(Str(Row_Count_M)) + ":" +
LTrim(Str(Row_Count_M))
Rows(CellPointer).Select
Selection.Delete Shift:=xlUp
Else
Cells(Row_Count_M, Column_GRMG).Select
ActiveCell.FormulaR1C1 = Trim(ActiveCell.FormulaR1C1) '
Tidy up GRMG
Row_Count_M = Row_Count_M + 1
End If
Loop
'
' Need to remove 2 from the row total, because we are currently
looking at
' the first blank row + 1
'
Row_Count_M = Row_Count_M - 2
'
' Impose standard formatting to whole spreadsheet
'
Range(Cells(Val(Start_Row), 1), Cells(Row_Count_M,
End_Column_Num)).Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = xlNone
Selection.NumberFormat = "#,##0"
'
' Format date columns
'
Columns(Column_Last_action).Select
Selection.NumberFormat = "m/d/yyyy"
Columns(Column_Next_Follow_Up).Select
Selection.NumberFormat = "m/d/yyyy"
'
' Call IFSE_Set_Values to modify the values in the IFSE_Master tab
' so that the pivot tables come out in the right order
'
'
' Now setup the necessary pivot tables
'
' First we need to find the column number of the last column in use.
' This is needed for the pivot commands
'
End_Row_C = Row_Count_C
End_Row_M = Row_Count_M
'
'
' Now create necessary pivot tables
'
Sheets("Master").Select
Cells.Select
Selection.Copy
Sheets("Consolidated").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
' Call IFSE_Clear_Values to modify the values in the IFSE_Master tab
' to remove the prefix added earlier
' Now hide control sheet
'
Sheets("Control").Select
Range("A1").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Master").Select
Range("A1").Select
' Now hide Master sheet
'
Sheets("Master").Select
Range("A1").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Consolidated").Select
Range("A1").Select
'
' Set application back to normal and display final message
'
Application.WindowState = xlNormal
DummyText = MsgBox("Spreadsheet Completion Complete. Please use
SaveAs to save spreadsheet", vbOKOnly)
ExitLabel:
End Sub
Thanks again
I've got a VB-Excel macro which help me to track some data from 5
differents tables and paste them in a final sheet I use on a basis each
week (see the code below), my problem is that the macro search data by
columns and past them by columns, what i want is to be able to past the
data I need by row.
Is it possible? Probably but after 24h of try I can make the right
correction.
Thanks for your help..........
Public Start_Row As String
Public End_Row_C As Integer
Public End_Row_M As Integer
Public End_Column_Num As Integer
Public Current_Week As Integer
'
Public Column_Customer As Integer
Public Column_Sector_SMB As Integer
Public Column_Business_Partner As Integer
Public Column_Brand As Integer
Public Column_GRMG As Integer
Public Column_Vol_GBP As Integer
Public Column_Vol_USD As Integer
Public Column_FSE As Integer
Public Column_ITSR As Integer
Public Column_Comments As Integer
Public Column_Last_action As Integer
Public Column_Next_Follow_Up As Integer
Public Column_Source As Integer
Public Column_Forecast As Integer
Public Column_GF_ODDS As Integer
Public Column_IBM_ODDS As Integer
Public Column_ROCK As Integer
Public Column_F_RISK As Integer
Public Column_BCD As Integer
Public Column_NIF As Integer
Public Column_ASSESS As Integer
Public Column_QVF As Integer
Public Column_QV As Integer
'
Public Spreadsheet_Name As String
Sub Forcast_Add_Data(File_Name As String)
'
' This macro adds cells from the spreadsheets in the file list
'
' Open the spreadsheet
'
'
' First find where we should insert the new test in the Master
'
Windows(Spreadsheet_Name).Activate
Sheets("Master").Select
Row_Count_M = Val(Start_Row)
Field1 = "****"
Field2 = "****"
'
Do While Field1 <> "" Or Field2 <> ""
CellPointer = "A" + LTrim(Str(Row_Count_M))
Range(CellPointer).Select
Field1 = ActiveCell.FormulaR1C1
CellPointer = "A" + LTrim(Str(Row_Count_M + 1))
Range(CellPointer).Select
Field2 = ActiveCell.FormulaR1C1
Row_Count_M = Row_Count_M + 1
Loop
'
' Row_Count_M now points at the first blank row + 1. Move back to
1st
' blank row.
'
Row_Count_M = Row_Count_M - 1
'
Workbooks.Open Filename:=File_Name, UpdateLinks:=0
Workbook_Name = ActiveWorkbook.Name
Windows(Workbook_Name).Activate
Sheets(1).Select
'
' Validate that the headings agree with the master ones
'
Validate_Flag = 1
Cells(Start_Row - 1, Column_Customer).Select
If UCase(ActiveCell.FormulaR1C1) <> "CUSTOMER" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Sector_SMB).Select
If UCase(ActiveCell.FormulaR1C1) <> "SECTOR/SMB" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Business_Partner).Select
If UCase(ActiveCell.FormulaR1C1) <> "BUSINESS PARTNER" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Brand).Select
If UCase(ActiveCell.FormulaR1C1) <> "BRAND" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Vol_GBP).Select
If UCase(ActiveCell.FormulaR1C1) <> "VOL (GBP) / £K" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Vol_USD).Select
If UCase(ActiveCell.FormulaR1C1) <> "VOL (USD) / $K" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Comments).Select
If UCase(ActiveCell.FormulaR1C1) <> "COMMENTS" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Last_action).Select
If UCase(ActiveCell.FormulaR1C1) <> "LAST ACTION" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Next_Follow_Up).Select
If UCase(ActiveCell.FormulaR1C1) <> "NEXT FOLLOW UP" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Source).Select
If UCase(ActiveCell.FormulaR1C1) <> "SOURCE" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_Forecast).Select
If UCase(ActiveCell.FormulaR1C1) <> "FORECAST" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_GF_ODDS).Select
If UCase(ActiveCell.FormulaR1C1) <> "GF ODDS" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_IBM_ODDS).Select
If UCase(ActiveCell.FormulaR1C1) <> "IBM ODDS" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_ROCK).Select
If UCase(ActiveCell.FormulaR1C1) <> "ROCK" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_F_RISK).Select
If UCase(ActiveCell.FormulaR1C1) <> "F/RISK" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_BCD).Select
If UCase(ActiveCell.FormulaR1C1) <> "BCD" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_NIF).Select
If UCase(ActiveCell.FormulaR1C1) <> "NIF" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_ASSESS).Select
If UCase(ActiveCell.FormulaR1C1) <> "ASSESS" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_QVF).Select
If UCase(ActiveCell.FormulaR1C1) <> "QVF" Then
Validate_Flag = 0
End If
Cells(Start_Row - 1, Column_QV).Select
If UCase(ActiveCell.FormulaR1C1) <> "QV" Then
Validate_Flag = 0
End If
If Validate_Flag <> 1 Then
MsgBox "Headings on detail spreadsheet do not match, results
may be wrong."
End If
'
Sheets(1).Select
Selection.ClearOutline
'
' Save values from C3 and C4
'
Range("C3").Select
Manager = ActiveCell.FormulaR1C1
'
' Find last row completed
'
Row_Count = Val(Start_Row)
Field1 = "****"
Field2 = "****"
'
Do While Field1 <> "" Or Field2 <> ""
CellPointer = "A" + LTrim(Str(Row_Count))
Range(CellPointer).Select
Field1 = ActiveCell.FormulaR1C1
CellPointer = "A" + LTrim(Str(Row_Count + 1))
Range(CellPointer).Select
Field2 = ActiveCell.FormulaR1C1
' Now clear validation from all columns
'
Range(Cells(Row_Count, 1), Cells(Row_Count,
End_Column_Num)).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly,
AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
Row_Count = Row_Count + 1
Loop
Row_Count = Row_Count - 1
Range(Cells(Val(Start_Row), 1), Cells(Row_Count - 1,
End_Column_Num)).Select
Selection.Copy
Windows(Spreadsheet_Name).Activate
Sheets("Master").Select
CellPointer = "A" + LTrim(Str(Row_Count_M))
Range(CellPointer).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteComments, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Selection.Copy
Windows(Workbook_Name).Activate
ActiveWindow.Close SaveChanges:=False
Windows(Spreadsheet_Name).Activate
Sheets("Master").Select
End Sub
Sub Forcast_Get_Input()
'
' Get list of files in directory C:\Documents and
Settings\gb011477\IFSE\My Documents\2006 Forcasts
' For each file found call macro Forcast_Add_Data to add data
' to master spreadsheet. Do not call Forcast_Add_Data for the master
yup
' spreadsheet itself.
'
'
' Prompt for Start Row and End Column
'
Start_Row = InputBox("Please enter the start row for data", "Enter
Start Row", "8")
'
'Prompt to include Slip/Lost rows
'
' Get spreadsheet name
'
Spreadsheet_Name = ActiveWorkbook.Name
'
' Look through columns and find column numbers for key columns
'
Sheets("Master").Select
'
Column_Customer = 0
Column_Sector_SMB = 0
Column_Business_Partner = 0
Column_Brand = 0
Column_Vol_GBP = 0
Column_Vol_USD = 0
Column_FSE = 0
Column_ITSR = 0
Column_Comments = 0
Column_GRMG = 0
Column_Last_action = 0
Column_Next_Follow_Up = 0
Column_Source = 0
Column_Forecast = 0
Column_GF_ODDS = 0
Column_IBM_ODDS = 0
Column_ROCK = 0
Column_F_RISK = 0
Column_BCD = 0
Column_NIF = 0
Column_ASSESS = 0
Column_QVF = 0
Column_QV = 0
Column_Count = 1
Do While Column_Count <= 99
Cells(Start_Row - 1, Column_Count).Select
If ActiveCell.FormulaR1C1 = "" Then ' reached end of
columns with data
Column_Count = 100
Else
Select Case UCase(ActiveCell.FormulaR1C1) ' Evaluate
CellContents
Case "CUSTOMER"
Column_Customer = Column_Count
Case "SECTOR/SMB"
Column_Sector_SMB = Column_Count
Case "BUSINESS PARTNER"
Column_Business_Partner = Column_Count
Case "BRAND"
Column_Brand = Column_Count
Case "VOL (GBP) / £K"
Column_Vol_GBP = Column_Count
Case "VOL (USD) / $K"
Column_Vol_USD = Column_Count
Case "FSE"
Column_FSE = Column_Count
Case "ITSR"
Column_ITSR = Column_Count
Case "COMMENTS"
Column_Comments = Column_Count
Case "GRMG"
Column_GRMG = Column_Count
Case "LAST ACTION"
Column_Last_action = Column_Count
Case "NEXT FOLLOW UP"
Column_Next_Follow_Up = Column_Count
Case "SOURCE"
Column_Source = Column_Count
Case "FORECAST"
Column_Forecast = Column_Count
Case "GF ODDS"
Column_GF_ODDS = Column_Count
Case "IBM ODDS"
Column_IBM_ODDS = Column_Count
Case "ROCK"
Column_ROCK = Column_Count
Case "F/RISK"
Column_F_RISK = Column_Count
Case "BCD"
Column_BCD = Column_Count
Case "NIF"
Column_NIF = Column_Count
Case "ASSESS"
Column_ASSESS = Column_Count
Case "QVF"
Column_QVF = Column_Count
Case "QV"
Column_QV = Column_Count
End Select
End If
Column_Count = Column_Count + 1
Loop
'
' Check that every column was found
'
If Column_Customer = 0 Or _
Column_Sector_SMB = 0 Or _
Column_Business_Partner = 0 Or _
Column_Brand = 0 Or _
Column_Vol_GBP = 0 Or _
Column_Vol_USD = 0 Or _
Column_FSE = 0 Or _
Column_ITSR = 0 Or _
Column_Comments = 0 Or _
Column_GRMG = 0 Or _
Column_Last_action = 0 Or _
Column_Next_Follow_Up = 0 Or _
Column_Source = 0 Or _
Column_Forecast = 0 Or _
Column_GF_ODDS = 0 Or _
Column_IBM_ODDS = 0 Or _
Column_ROCK = 0 Or _
Column_F_RISK = 0 Or _
Column_BCD = 0 Or _
Column_NIF = 0 Or _
Column_ASSESS = 0 Or _
Column_QVF = 0 Or _
Column_QV = 0 Then
Application.WindowState = xlNormal
DummyText = MsgBox("Cannot find all columns", vbOKCancel)
GoTo ExitLabel
End If
End_Column_Num = Column_QV
Sheets("Control").Select
'
' Loop through all files in directory
'
Set fs = Application.FileSearch
With fs
.LookIn = "C:\$User\2006 Forecasts"
.Filename = "*.xls"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
For I = 1 To .FoundFiles.Count
If InStr(.FoundFiles(I), Spreadsheet_Name) = 0 Then
Forcast_Add_Data .FoundFiles(I)
End If
Next I
Else
MsgBox "There were no files found."
GoTo ExitLabel
End If
End With
'
' Now tidy up resulting spreadsheet
'
Row_Count_M = Val(Start_Row)
Field1 = "****"
Field2 = "****"
Field1A = "****"
'
Do While Field1 <> "" Or Field2 <> ""
Cells(Row_Count_M, Column_Customer).Select ' Customer
Field1 = ActiveCell.FormulaR1C1
Cells(Row_Count_M, Column_Vol_GBP).Select ' Value
Field1A = ActiveCell.FormulaR1C1
Cells(Row_Count_M + 1, Column_Customer).Select
Field2 = ActiveCell.FormulaR1C1
'
' Clear out any blank rows and also old slip rows if
parameter set
'
If Trim(Field1) = "" And Trim(Field1A) = "" And
Trim(Field2) <> "" Then
CellPointer = LTrim(Str(Row_Count_M)) + ":" +
LTrim(Str(Row_Count_M))
Rows(CellPointer).Select
Selection.Delete Shift:=xlUp
Else
Cells(Row_Count_M, Column_GRMG).Select
ActiveCell.FormulaR1C1 = Trim(ActiveCell.FormulaR1C1) '
Tidy up GRMG
Row_Count_M = Row_Count_M + 1
End If
Loop
'
' Need to remove 2 from the row total, because we are currently
looking at
' the first blank row + 1
'
Row_Count_M = Row_Count_M - 2
'
' Impose standard formatting to whole spreadsheet
'
Range(Cells(Val(Start_Row), 1), Cells(Row_Count_M,
End_Column_Num)).Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = xlNone
Selection.NumberFormat = "#,##0"
'
' Format date columns
'
Columns(Column_Last_action).Select
Selection.NumberFormat = "m/d/yyyy"
Columns(Column_Next_Follow_Up).Select
Selection.NumberFormat = "m/d/yyyy"
'
' Call IFSE_Set_Values to modify the values in the IFSE_Master tab
' so that the pivot tables come out in the right order
'
'
' Now setup the necessary pivot tables
'
' First we need to find the column number of the last column in use.
' This is needed for the pivot commands
'
End_Row_C = Row_Count_C
End_Row_M = Row_Count_M
'
'
' Now create necessary pivot tables
'
Sheets("Master").Select
Cells.Select
Selection.Copy
Sheets("Consolidated").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
' Call IFSE_Clear_Values to modify the values in the IFSE_Master tab
' to remove the prefix added earlier
' Now hide control sheet
'
Sheets("Control").Select
Range("A1").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Master").Select
Range("A1").Select
' Now hide Master sheet
'
Sheets("Master").Select
Range("A1").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Consolidated").Select
Range("A1").Select
'
' Set application back to normal and display final message
'
Application.WindowState = xlNormal
DummyText = MsgBox("Spreadsheet Completion Complete. Please use
SaveAs to save spreadsheet", vbOKOnly)
ExitLabel:
End Sub
Thanks again