Inserting Filtered RC cell information into other worksheets

Dennis · 07-18-2005, 11:05 AM

Unsing 2003

Created a macro to add then copy/past cell info from one worksheet to a
series of other new worksheets. Works fine.

The reason for the macro was to automate the process of adding a worksheet
(which is limited to the 255 character limit) then copy/paste cells so as to
overcome the 255/per cell limitation.

Now I have a new series of worksheets "A 1 thru 10".

I would like to populate the cells of the new worksheets with certain cells
existing on another worksheet, Named "B", which has filtered data.

Thus worksheet A1 has 10 cells (in a different layout on W/S "B"). I want
to populate A1 then, A2, A3 .... etc., with cells from W/S "B" where the
"Visible Rows" may be
Row 3 next 7 next 20, next 57.

So A1 is populated with W/S "B" Row 3 information
A2 is populated with W/S "B" Row 7 info
A3 is populated with W/S "B" Row 20 info (and so on)

I am not sure how to cause a VBA loop to skip through W/S "B" visible rows,
populate the various "A" series W/S and then stop when the last visible row
on "B" is encountered.

So I need a counter? that increments non-sequentially?
knows how many "A" W/S to populate and stops when all visible row
information is completed.

Not sure whether to use .Offset() or what ever.

Any help would be appreciated.

Dennis

BTW the macro so far is:

Sub WorkSheetCopy()
'
'
' Assumes that the ActiveSheet is the Copy-from Worksheet
'
'
'
' Keyboard Shortcut: Ctrl+Shift+W
'
'
Dim WorkSheetNumber As Long
Dim OrigWorkSheetName As String
ActiveSheet.Select
OrigWorkSheetName = ActiveSheet.Name
ActiveSheet.Copy After:=ActiveWorkbook.Worksheets _
(ActiveWorkbook.Sheets.count)
WorkSheetNumber = ActiveWorkbook.Sheets.count
Sheets(OrigWorkSheetName).Select
Cells.Select
Selection.Copy
Sheets(WorkSheetNumber).Select
Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Sheets(OrigWorkSheetName).Select
Range("A1").Select
End Sub

Jim Rech · 07-18-2005, 02:05 PM

Dennis · 07-18-2005, 03:05 PM

Dave Peterson · 07-18-2005, 03:05 PM

An unfortunate name of worksheets (A1 thru A10). It makes it look like cell
addresses.

But maybe something like this will show you one way to go through the visible
cells:

Option Explicit
Sub testme()

Dim fWks As Worksheet 'from worksheet
Dim iCtr As Long
Dim rngF As Range
Dim myCell As Range

With ActiveSheet.AutoFilter.Range
Set rngF = Nothing
On Error Resume Next
Set rngF = .Columns(1).Cells.Resize(.Rows.Count - 1, 1).Offset(1, 0) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngF Is Nothing Then
'only the header is visible
MsgBox "no details shown"
Else
iCtr = 0
For Each myCell In rngF.Cells
iCtr = iCtr + 1
If WorksheetExists("a" & iCtr, ActiveWorkbook) Then
'it's there
Else
'add it
Worksheets.Add
ActiveSheet.Name = "A" & iCtr
End If

myCell.EntireRow.Copy _
Destination:=Worksheets("a" & iCtr).Range("a1")
Next myCell

End If
End With
End Sub
Function WorksheetExists(SheetName As Variant, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function

The WorksheetExists function was taken from a Chip Pearson post. (I like it!)

Dennis wrote:
>
> Unsing 2003
>
> Created a macro to add then copy/past cell info from one worksheet to a
> series of other new worksheets. Works fine.
>
> The reason for the macro was to automate the process of adding a worksheet
> (which is limited to the 255 character limit) then copy/paste cells so as to
> overcome the 255/per cell limitation.
>
> Now I have a new series of worksheets "A 1 thru 10".
>
> I would like to populate the cells of the new worksheets with certain cells
> existing on another worksheet, Named "B", which has filtered data.
>
> Thus worksheet A1 has 10 cells (in a different layout on W/S "B"). I want
> to populate A1 then, A2, A3 .... etc., with cells from W/S "B" where the
> "Visible Rows" may be
> Row 3 next 7 next 20, next 57.
>
> So A1 is populated with W/S "B" Row 3 information
> A2 is populated with W/S "B" Row 7 info
> A3 is populated with W/S "B" Row 20 info (and so on)
>
> I am not sure how to cause a VBA loop to skip through W/S "B" visible rows,
> populate the various "A" series W/S and then stop when the last visible row
> on "B" is encountered.
>
> So I need a counter? that increments non-sequentially?
> knows how many "A" W/S to populate and stops when all visible row
> information is completed.
>
> Not sure whether to use .Offset() or what ever.
>
> Any help would be appreciated.
>
> Dennis
>
> BTW the macro so far is:
>
> Sub WorkSheetCopy()
> '
> '
> ' Assumes that the ActiveSheet is the Copy-from Worksheet
> '
> '
> '
> ' Keyboard Shortcut: Ctrl+Shift+W
> '
> '
> Dim WorkSheetNumber As Long
> Dim OrigWorkSheetName As String
> ActiveSheet.Select
> OrigWorkSheetName = ActiveSheet.Name
> ActiveSheet.Copy After:=ActiveWorkbook.Worksheets _
> (ActiveWorkbook.Sheets.count)
> WorkSheetNumber = ActiveWorkbook.Sheets.count
> Sheets(OrigWorkSheetName).Select
> Cells.Select
> Selection.Copy
> Sheets(WorkSheetNumber).Select
> Cells.Select
> ActiveSheet.Paste
> Application.CutCopyMode = False
> Range("A1").Select
> Sheets(OrigWorkSheetName).Select
> Range("A1").Select
> End Sub

--

Dave Peterson

Dennis · 07-18-2005, 03:05 PM

Dennis · 07-18-2005, 06:05 PM

Dave,

I will enjoy tailoring this as I follow almost all of it. If I need any
additional, I add here - I'll do my best to take it the rest of the way.
Thanks for the heavy lifting!

Dennis

"Dave Peterson" wrote:

> An unfortunate name of worksheets (A1 thru A10). It makes it look like cell
> addresses.
>
> But maybe something like this will show you one way to go through the visible
> cells:
>
> Option Explicit
> Sub testme()
>
> Dim fWks As Worksheet 'from worksheet
> Dim iCtr As Long
> Dim rngF As Range
> Dim myCell As Range
>
> With ActiveSheet.AutoFilter.Range
> Set rngF = Nothing
> On Error Resume Next
> Set rngF = .Columns(1).Cells.Resize(.Rows.Count - 1, 1).Offset(1, 0) _
> .SpecialCells(xlCellTypeVisible)
> On Error GoTo 0
> If rngF Is Nothing Then
> 'only the header is visible
> MsgBox "no details shown"
> Else
> iCtr = 0
> For Each myCell In rngF.Cells
> iCtr = iCtr + 1
> If WorksheetExists("a" & iCtr, ActiveWorkbook) Then
> 'it's there
> Else
> 'add it
> Worksheets.Add
> ActiveSheet.Name = "A" & iCtr
> End If
>
> myCell.EntireRow.Copy _
> Destination:=Worksheets("a" & iCtr).Range("a1")
> Next myCell
>
> End If
> End With
> End Sub
> Function WorksheetExists(SheetName As Variant, _
> Optional WhichBook As Workbook) As Boolean
> 'from Chip Pearson
> Dim WB As Workbook
> Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
> On Error Resume Next
> WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
> End Function
>
> The WorksheetExists function was taken from a Chip Pearson post. (I like it!)
>
> Dennis wrote:
> >
> > Unsing 2003
> >
> > Created a macro to add then copy/past cell info from one worksheet to a
> > series of other new worksheets. Works fine.
> >
> > The reason for the macro was to automate the process of adding a worksheet
> > (which is limited to the 255 character limit) then copy/paste cells so as to
> > overcome the 255/per cell limitation.
> >
> > Now I have a new series of worksheets "A 1 thru 10".
> >
> > I would like to populate the cells of the new worksheets with certain cells
> > existing on another worksheet, Named "B", which has filtered data.
> >
> > Thus worksheet A1 has 10 cells (in a different layout on W/S "B"). I want
> > to populate A1 then, A2, A3 .... etc., with cells from W/S "B" where the
> > "Visible Rows" may be
> > Row 3 next 7 next 20, next 57.
> >
> > So A1 is populated with W/S "B" Row 3 information
> > A2 is populated with W/S "B" Row 7 info
> > A3 is populated with W/S "B" Row 20 info (and so on)
> >
> > I am not sure how to cause a VBA loop to skip through W/S "B" visible rows,
> > populate the various "A" series W/S and then stop when the last visible row
> > on "B" is encountered.
> >
> > So I need a counter? that increments non-sequentially?
> > knows how many "A" W/S to populate and stops when all visible row
> > information is completed.
> >
> > Not sure whether to use .Offset() or what ever.
> >
> > Any help would be appreciated.
> >
> > Dennis
> >
> > BTW the macro so far is:
> >
> > Sub WorkSheetCopy()
> > '
> > '
> > ' Assumes that the ActiveSheet is the Copy-from Worksheet
> > '
> > '
> > '
> > ' Keyboard Shortcut: Ctrl+Shift+W
> > '
> > '
> > Dim WorkSheetNumber As Long
> > Dim OrigWorkSheetName As String
> > ActiveSheet.Select
> > OrigWorkSheetName = ActiveSheet.Name
> > ActiveSheet.Copy After:=ActiveWorkbook.Worksheets _
> > (ActiveWorkbook.Sheets.count)
> > WorkSheetNumber = ActiveWorkbook.Sheets.count
> > Sheets(OrigWorkSheetName).Select
> > Cells.Select
> > Selection.Copy
> > Sheets(WorkSheetNumber).Select
> > Cells.Select
> > ActiveSheet.Paste
> > Application.CutCopyMode = False
> > Range("A1").Select
> > Sheets(OrigWorkSheetName).Select
> > Range("A1").Select
> > End Sub
>
> --
>
> Dave Peterson
>

Dennis · 07-29-2005, 11:05 AM

Dave, (I hope that you read this!)

It took me a while to "perfect" this procedure. Obviously I am not that
good with VBA. Saying that, this procedure and call to another works very
well as intended.

As an accountant, my real work is accounting, audit, and Sarbanes-Oxley
(SOX) tasks. VBA is my hobby.

We SOX people have a number of "Remediation" w/s to be generated from a
result a "Master" control w/s.

It is not pretty, but it does the job and you were the one who gave me
significant clue's.

I would like to share it with others as many of you do for we humbler XL
users.

Thank you again, Dennis

************************************************************
Sub ABBPopulateWorksheet()
'
'Source Dave Peterson 7/18/2005 heavily modified 7/29/2005 9:30 AM to
DMB special use
'
'
'This Procedure is Calls Sub ABBOneCellText() and its result is the
variable TextVar
' In order to maintain the Variable TextVar, see two lines below.
'
'NOTE: "Dim TextVar As String" must be placed outside of both related
Sub Routines.
' Place it at the top of this module file
'
If MsgBox("To succesfully run this Macro, these items must be known or
established beforehand: " + Chr(10) _
& " The worksheet with the data to pass into another
worksheet must be the file from which you start" + Chr(10) _
& " the macro. i.e. (must be the active sheet).
This sheet is the DataSourceSheet." + Chr(10) + Chr(10) _
& "Obtain the full file-name AND Sheetname of the Excel
Workbook/Sheet to be the Template format" + Chr(10) _
& "Obtain the full file-name AND Sheetname of the Excel
Workbook/Sheet into which the data will be placed" + Chr(10) + Chr(10) _
& "Also obtain the Column letters of the final Control
definition, Control Owner, Control Number and Risk Number" + Chr(10) +
Chr(10) _
& "ARE YOU READY TO CONTINUE?", vbYesNo, "NOTICE") = vbNo Then
Exit Sub

Dim myOrigSheetProtectStatus As Boolean
Dim DataSourceBook As Workbook 'Data "from" workbook
Dim DataSourceSheet As Worksheet 'Data "from" worksheet
Dim CopyFromBook As Workbook 'Workbook to use as template
Dim CopyFromSheet As Worksheet 'Worksheet to use as template
Dim ReceiveBook As Workbook 'Workbook to be populated
Dim ReceiveSheetName As String 'Worksheet to be populated
Dim DataSourcePath As String 'Path for all files
Dim CopyFromBookName As String 'Workbook to use as template
Dim CopyFromSheetName As String 'Workbook to use as template
Dim CopyFromSheetNameOrig As String 'Workbook to use as template
Dim ReceiveBookName As String 'Workbook to be populated
Dim DataSourceBookName As String 'Data "from" workbook name
Dim DataSourceSheetName As String 'Data "from" worksheet name
Dim VisibleRowsCounter As Long 'Counts visable rows after filtering
Dim VisibleRowsRange As Range 'Range of all Visable Rows
Dim MyCell As Range 'used to ID and select Rows with data
Dim SheetExists As Boolean 'Logical status (existance) of a sheet
Dim ColLtrControlNumber As String 'Column Letter(s) of Control Numbers
Dim ColLtrControlDescrip As String 'Column Letter(s) of Control
Description
Dim ColLtrControlBy As String 'Column Letter(s) of Control Owner
Dim ColLtrRiskNumber As String 'Column Letter(s) of Risk Number
Dim Continue As Boolean
Dim Counter As Long
' Must have the Data source workbook open and the filter ranges set
'
Continue = True
Do While Continue = True
On Error Resume Next
myOrigSheetProtectStatus = ActiveSheet.ProtectContents
If myOrigSheetProtectStatus = True Then
ActiveSheet.Protect UserInterfaceOnly:=True
End If
If Error Then
If MsgBox("There is no Active Worksheet ......... Exiting Routine
...", vbOKOnly, _
"NOTICE") = vbOK Then Exit Sub
End If
Set DataSourceBook = ActiveWorkbook
Set DataSourceSheet = ActiveSheet
'
'Note: Worksheet Tab names are limited to 31 characters. The
process below, adds 7
' characters to the source tab name, (i.e." GAP nn") therefore the
original tab name can not
' exceed 24 characters
'
If Len(DataSourceSheet.Name) > 24 Then
MsgBox ("NOTE: The Data-Source Tab Label [" &
DataSourceSheet.Name & _
"] will be truncated to 24 Characters!!")
End If
DataSourceSheetName = Trim(Mid(DataSourceSheet.Name, 1, 24))
DataSourceSheet.Name = DataSourceSheetName
CopyFromSheetName = "GAP Template"
CopyFromSheetNameOrig = "GAP Template"
' Determines the path of the Data source workbook and saves it as a
variable
' to use below
DataSourcePath = DataSourceBook.Path
DataSourceBookName = DataSourceBook.Name
' Opens up the workbook from which the one and only W/S will become
a "template" for use below
DataSourceBookName = InputBox("Enter the complete File Name
including the Extension" & Chr(10) _
& "of the File from which the data will come", ,
DataSourceBookName)
If DataSourceBookName = "" Then
MsgBox "Valid Data not Entered - CANCELLED!"
Exit Sub
End If
ReceiveBookName = InputBox("Enter the complete File Name including
the Extension" & Chr(10) & _
"of the File into which the data will go" & Chr(10) & Chr(10) &
"NOTE: The first Sheet in " & _
"the ReceiveBook will be the Template", , ReceiveBookName)
If ReceiveBookName = "" Then
MsgBox "Valid Data not Entered - CANCELLED!"
Exit Sub
End If
CopyFromBookName = InputBox("Enter the complete File Name including
the Extension" & Chr(10) & _
"of the File ""Template"" to Copy From", , CopyFromBookName)
CopyFromSheetName = InputBox("Enter the SHEET Name to be copied in
the File 'Template' to" & _
"Copy From", , CopyFromSheetName)
Set CopyFromBook = Nothing
On Error Resume Next
Set CopyFromBook = Workbooks(CopyFromBookName)
On Error GoTo 0
If CopyFromBook Is Nothing Then
Set CopyFromBook = Workbooks.Open(fileName:=DataSourcePath & "\"
& CopyFromBookName)
End If
Set ReceiveBook = Nothing
On Error Resume Next
Set ReceiveBook = Workbooks(ReceiveBookName)
On Error GoTo 0
If ReceiveBook Is Nothing Then
Set ReceiveBook = Workbooks.Open(fileName:=DataSourcePath &
"\" & ReceiveBookName)
If Error Then
Workbooks.Add
Workbooks("Book1").SaveAs (DataSourcePath & "\" &
ReceiveBookName)
End If
On Error GoTo 0
End If
' ReceiveBook should have THE FIRST sheet cloned as a template.
DataSourceBook.Activate
DataSourceSheet.Activate
On Error Resume Next
With DataSourceSheet.AutoFilter.Range
Set VisibleRowsRange = Nothing
On Error Resume Next
Set VisibleRowsRange = .Columns(1).Cells.Resize(.Rows.count - 1,
1).Offset(1, 0).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If VisibleRowsRange Is Nothing Then
'only the header is visible
MsgBox " No filtered details
shown !!!" + Chr(10) + Chr(10) + _
"The Template W/S must be Active when you start this Macro"
+ Chr(10) + _
"Also make sure that AutoFilter is actively filtering one
Column"
Else
VisibleRowsCounter = 0
' Note: the range is one-cell wide. Thus VisibleRowsCounter
will increment until = number of rows
For Each MyCell In VisibleRowsRange.Cells
VisibleRowsCounter = VisibleRowsCounter + 1
Dim WSName As String
WSName = DataSourceSheetName & " GAP " &
VisibleRowsCounter
If WorksheetExists(WSName, ReceiveBook) Then
If MsgBox("Be aware that you may be duplicating
worksheets!" + Chr(10) & Chr(10) & _
"Do you wish to Continue?", vbYesNo) = vbNo Then
Exit Sub
CopyFromSheetName = WSName
Else
If WorksheetExists("GAP Template", ReceiveBook) Then
CopyFromSheetName = "GAP Template"
' Do not wish to count the Template w/s
VisibleRowsCounter = VisibleRowsCounter - 1
Else
MsgBox ("Add a Worksheet to Copy From and Name
it 'GAP Template'")
Exit Sub
End If
End If
ReceiveBook.Worksheets.Add
After:=ReceiveBook.Worksheets(ReceiveBook.Sheets.count)
VisibleRowsCounter = VisibleRowsCounter + 1
NewSheetName = ReceiveBook.ActiveSheet.Name
ReceiveBook.Sheets(NewSheetName).Activate
Counter = VisibleRowsCounter
'This loop checks if there is a worksheet with the same
name
Do While WorksheetExists(DataSourceSheetName & " GAP " &
Counter, ReceiveBook)
Counter = Counter + 1
Loop
ReceiveBook.Sheets(NewSheetName).Name =
DataSourceSheetName & " GAP " & Counter
ReceiveSheetName = DataSourceSheetName & " GAP " & Counter
' On Error Resume Next
ReceiveBook.ActiveSheet.Name = ReceiveSheetName
CopyFromBook.Worksheets(CopyFromSheetName).Activate
Cells.Copy
ReceiveBook.Worksheets(ReceiveSheetName).Activate
ReceiveBook.Worksheets(ReceiveSheetName).Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ReceiveBook.Worksheets(ReceiveSheetName).Paste
CopyFromBook.Worksheets(CopyFromSheetName).Activate
Cells.Copy
ReceiveBook.Worksheets(ReceiveSheetName).Activate
ReceiveBook.Worksheets(ReceiveSheetName).Select
Cells.Select
ReceiveBook.Worksheets(ReceiveSheetName).Paste
Application.CutCopyMode = False
DataSourceBook.Activate
If VisibleRowsCounter < 3 Then
ColLtrControlNumber = Trim(InputBox("Control
Number", "Enter Column Letter(s) of:", "K"))
ColLtrControlDescrip = Trim(InputBox("Actual
Control", "Enter Column Letter(s) of:", "L"))
ColLtrControlBy = Trim(InputBox("Control Performed
By", "Enter Column Letter(s) of:", "O"))
ColLtrRiskNumber = Trim(InputBox("Risk Number",
"Enter Column Letter(s) of:", "G"))
End If
Sheets(1).Activate
Call ABBOneCellText
ReceiveBook.Worksheets(ReceiveSheetName).Activate
ActiveSheet.Range("A4").Value = Mid(DataSourceBookName,
1, 12)
ActiveSheet.Range("A4").Font.ColorIndex = 5
ActiveSheet.Range("A6").Value = TextVar
ActiveSheet.Range("A6").Font.ColorIndex = 5
ActiveSheet.Range("A8").Formula = "=MID('[" &
DataSourceBookName & "]" & _
DataSourceSheetName & "'!" & ColLtrControlNumber &
MyCell.Cells.Row & ",1,1)" '
ActiveSheet.Range("A8").Font.ColorIndex = 5
ActiveSheet.Range("A10").Formula = "='[" &
DataSourceBookName & "]" & _
DataSourceSheetName & "'!" & ColLtrControlDescrip &
MyCell.Cells.Row
ActiveSheet.Range("A10").Font.ColorIndex = 5
ActiveSheet.Range("D4").Value = Mid(Now(), 1, 10)
ActiveSheet.Range("D4").Font.ColorIndex = 5
ActiveSheet.Range("F4").Formula = "='[" &
DataSourceBookName & "]" & _
DataSourceSheetName & "'!" & ColLtrControlBy &
MyCell.Cells.Row
ActiveSheet.Range("F4").Font.ColorIndex = 5
ActiveSheet.Range("F8").Formula = "='[" &
DataSourceBookName & "]" & _
DataSourceSheetName & "'!" & ColLtrRiskNumber &
MyCell.Cells.Row
ActiveSheet.Range("F8").Font.ColorIndex = 5
ActiveSheet.Range("I4").Formula = "='[" &
DataSourceBookName & "]" & _
DataSourceSheetName & "'!" & ColLtrControlNumber &
MyCell.Cells.Row
ActiveSheet.Range("I4").Font.ColorIndex = 5
ReceiveBook.Worksheets(ReceiveSheetName).Select
Cells.Select
With Selection
.Copy
.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
Range("A1").Select
Next MyCell
End If
End With
If myOrigSheetProtectStatus = True Then
DataSourceSheet.Protect UserInterfaceOnly:=False
End If
If MsgBox("Press YES to Continue Processing Sheets", vbYesNo) = vbNo
Then Continue = False
'Activate book and sheets which were active in the beginning of the
process
DataSourceBook.Activate
DataSourceSheet.Activate
Loop
' If WorksheetExists("GAP Template", ReceiveBook) And
ReceiveBook.Sheets.count > 1 Then
' ReceiveBook.Activate
' Application.DisplayAlerts = False
' Sheets("GAP Template").Delete
' Application.DisplayAlerts = True
' End If

MsgBox "Process Completed! Press OK to Continue"

End Sub

'The following VBA code finds a location in your worksheet [Sheets(1) in
this case],
'you then manually create an Offset setting from the text-find
'Cells.Find(What:="Your Choice of Text") to the actual data that you wish to
utilize.

'Once the range "MyRange" is computed, another loop computes a Variable
"TextVar"
'which represents the information in the "MyRange" cells in a Text variable
that can
'be saved in another cell/Worksheet.

'This can be a great help to those doing SOX work where a great deal of data
' rollups occur.
'
'Assistance from Jim Rech 7/26/2005 Excel.General
'

Sub ABBOneCellText()
'
'Assistance from Jim Rech 7/26/2005 Excel.General
'
'This Procedure is called from ABBPopulateWorksheet()
'
'NOTE: "Dim TextVar As String" must be placed outside of both related
Sub Routines.
' Place it at the top of this module file
'
Dim MyRange As Range
Dim MyCell As Range
Dim LastDataColumn As Integer
Dim LastDataRow As Integer
Dim FirstDataColumn As Integer
Dim FirstDataRow As Integer
'
'Note: Do NOT "Dim TextVar As String" in this module
'
' "Finds the 1st instance of the use of "IMPACTED ABACUS" in the W/S and
Offsets
' to the first cell with meaningful data
Set MyRange = Sheets(1).Cells.Find(What:="IMPACTED ABACUS").Offset(2, 3)
'Establishes the upperleft row number
FirstDataRow = MyRange.Row
LastDataRow = FirstDataRow
'Establishes the upperleft Column number
FirstDataColumn = MyRange.Column
LastDataColumn = FirstDataColumn
' Loop computes last column with data
Do While Not IsEmpty(Rows(FirstDataRow).Cells(LastDataColumn))
LastDataColumn = LastDataColumn + 1
Loop
'Represents the last column with meaningful data in the 1st meaningful
row of data
LastDataColumn = LastDataColumn - 1
Do While Not IsEmpty(Columns(FirstDataColumn).Cells(LastDataRow))
LastDataRow = LastDataRow + 1
Loop
'Represents the last row with meaningful data in the "MyRange" row of data
LastDataRow = LastDataRow - 1
'Establishes or "Sets" the Meaningful Data range
Set MyRange = Range(Cells(FirstDataRow, FirstDataColumn),
Cells(LastDataRow, LastDataColumn))
TextVar = Empty
For Each MyCell In MyRange
If MyCell.Value <> "" Then TextVar = TextVar + MyCell.Value + Chr(10)
Next MyCell
'Clears any previous selections to A1
Range("A1").Select
End Sub

Sub GetRealLastCell()
' Tom Olgavy Excel.General 7/6/2005
Dim RealLastRow As Long
Dim RealLastColumn As Long
Range("A1").Select
On Error Resume Next
RealLastRow = _
Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
RealLastColumn = _
Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column
Cells(RealLastRow, RealLastColumn).Select
End Sub
************************************************************

"Dave Peterson" wrote:

> An unfortunate name of worksheets (A1 thru A10). It makes it look like cell
> addresses.
>
> But maybe something like this will show you one way to go through the visible
> cells:
>
> Option Explicit
> Sub testme()
>
> Dim fWks As Worksheet 'from worksheet
> Dim iCtr As Long
> Dim rngF As Range
> Dim myCell As Range
>
> With ActiveSheet.AutoFilter.Range
> Set rngF = Nothing
> On Error Resume Next
> Set rngF = .Columns(1).Cells.Resize(.Rows.Count - 1, 1).Offset(1, 0) _
> .SpecialCells(xlCellTypeVisible)
> On Error GoTo 0
> If rngF Is Nothing Then
> 'only the header is visible
> MsgBox "no details shown"
> Else
> iCtr = 0
> For Each myCell In rngF.Cells
> iCtr = iCtr + 1
> If WorksheetExists("a" & iCtr, ActiveWorkbook) Then
> 'it's there
> Else
> 'add it
> Worksheets.Add
> ActiveSheet.Name = "A" & iCtr
> End If
>
> myCell.EntireRow.Copy _
> Destination:=Worksheets("a" & iCtr).Range("a1")
> Next myCell
>
> End If
> End With
> End Sub
> Function WorksheetExists(SheetName As Variant, _
> Optional WhichBook As Workbook) As Boolean
> 'from Chip Pearson
> Dim WB As Workbook
> Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
> On Error Resume Next
> WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
> End Function
>
> The WorksheetExists function was taken from a Chip Pearson post. (I like it!)
>
> Dennis wrote:
> >
> > Unsing 2003
> >
> > Created a macro to add then copy/past cell info from one worksheet to a
> > series of other new worksheets. Works fine.
> >
> > The reason for the macro was to automate the process of adding a worksheet
> > (which is limited to the 255 character limit) then copy/paste cells so as to
> > overcome the 255/per cell limitation.
> >
> > Now I have a new series of worksheets "A 1 thru 10".
> >
> > I would like to populate the cells of the new worksheets with certain cells
> > existing on another worksheet, Named "B", which has filtered data.
> >
> > Thus worksheet A1 has 10 cells (in a different layout on W/S "B"). I want
> > to populate A1 then, A2, A3 .... etc., with cells from W/S "B" where the
> > "Visible Rows" may be
> > Row 3 next 7 next 20, next 57.
> >
> > So A1 is populated with W/S "B" Row 3 information
> > A2 is populated with W/S "B" Row 7 info
> > A3 is populated with W/S "B" Row 20 info (and so on)
> >
> > I am not sure how to cause a VBA loop to skip through W/S "B" visible rows,
> > populate the various "A" series W/S and then stop when the last visible row
> > on "B" is encountered.
> >
> > So I need a counter? that increments non-sequentially?
> > knows how many "A" W/S to populate and stops when all visible row
> > information is completed.
> >
> > Not sure whether to use .Offset() or what ever.
> >
> > Any help would be appreciated.
> >
> > Dennis
> >
> > BTW the macro so far is:
> >
> > Sub WorkSheetCopy()
> > '
> > '
> > ' Assumes that the ActiveSheet is the Copy-from Worksheet
> > '
> > '
> > '
> > ' Keyboard Shortcut: Ctrl+Shift+W
> > '
> > '
> > Dim WorkSheetNumber As Long
> > Dim OrigWorkSheetName As String
> > ActiveSheet.Select
> > OrigWorkSheetName = ActiveSheet.Name
> > ActiveSheet.Copy After:=ActiveWorkbook.Worksheets _
> > (ActiveWorkbook.Sheets.count)
> > WorkSheetNumber = ActiveWorkbook.Sheets.count
> > Sheets(OrigWorkSheetName).Select
> > Cells.Select
> > Selection.Copy
> > Sheets(WorkSheetNumber).Select
> > Cells.Select
> > ActiveSheet.Paste
> > Application.CutCopyMode = False
> > Range("A1").Select
> > Sheets(OrigWorkSheetName).Select
> > Range("A1").Select
> > End Sub
>
> --
>
> Dave Peterson
>

Dennis · 07-29-2005, 11:05 AM

Dennis · 07-29-2005, 11:05 AM

To all of those who may be interested, there is also a Function() utilized
in the macro that you may not have.
Place this Function() in the same VBA Module as the above macro.

Dennis

*****************************************************

Function WorksheetExists(SheetName As Variant, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson via Dave Peterson 7/19/2005
' for Add Worksheet() and PopulateWorksheet()
'
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function

"Dennis" wrote:

> Dave, (I hope that you read this!)
>
> It took me a while to "perfect" this procedure. Obviously I am not that
> good with VBA. Saying that, this procedure and call to another works very
> well as intended.
>
> As an accountant, my real work is accounting, audit, and Sarbanes-Oxley
> (SOX) tasks. VBA is my hobby.
>
> We SOX people have a number of "Remediation" w/s to be generated from a
> result a "Master" control w/s.
>
> It is not pretty, but it does the job and you were the one who gave me
> significant clue's.
>
> I would like to share it with others as many of you do for we humbler XL
> users.
>
>
> Thank you again, Dennis
>
> ************************************************************
> Sub ABBPopulateWorksheet()
> '
> 'Source Dave Peterson 7/18/2005 heavily modified 7/29/2005 9:30 AM to
> DMB special use
> '
> '
> 'This Procedure is Calls Sub ABBOneCellText() and its result is the
> variable TextVar
> ' In order to maintain the Variable TextVar, see two lines below.
> '
> 'NOTE: "Dim TextVar As String" must be placed outside of both related
> Sub Routines.
> ' Place it at the top of this module file
> '
> If MsgBox("To succesfully run this Macro, these items must be known or
> established beforehand: " + Chr(10) _
> & " The worksheet with the data to pass into another
> worksheet must be the file from which you start" + Chr(10) _
> & " the macro. i.e. (must be the active sheet).
> This sheet is the DataSourceSheet." + Chr(10) + Chr(10) _
> & "Obtain the full file-name AND Sheetname of the Excel
> Workbook/Sheet to be the Template format" + Chr(10) _
> & "Obtain the full file-name AND Sheetname of the Excel
> Workbook/Sheet into which the data will be placed" + Chr(10) + Chr(10) _
> & "Also obtain the Column letters of the final Control
> definition, Control Owner, Control Number and Risk Number" + Chr(10) +
> Chr(10) _
> & "ARE YOU READY TO CONTINUE?", vbYesNo, "NOTICE") = vbNo Then
> Exit Sub
>
> Dim myOrigSheetProtectStatus As Boolean
> Dim DataSourceBook As Workbook 'Data "from" workbook
> Dim DataSourceSheet As Worksheet 'Data "from" worksheet
> Dim CopyFromBook As Workbook 'Workbook to use as template
> Dim CopyFromSheet As Worksheet 'Worksheet to use as template
> Dim ReceiveBook As Workbook 'Workbook to be populated
> Dim ReceiveSheetName As String 'Worksheet to be populated
> Dim DataSourcePath As String 'Path for all files
> Dim CopyFromBookName As String 'Workbook to use as template
> Dim CopyFromSheetName As String 'Workbook to use as template
> Dim CopyFromSheetNameOrig As String 'Workbook to use as template
> Dim ReceiveBookName As String 'Workbook to be populated
> Dim DataSourceBookName As String 'Data "from" workbook name
> Dim DataSourceSheetName As String 'Data "from" worksheet name
> Dim VisibleRowsCounter As Long 'Counts visable rows after filtering
> Dim VisibleRowsRange As Range 'Range of all Visable Rows
> Dim MyCell As Range 'used to ID and select Rows with data
> Dim SheetExists As Boolean 'Logical status (existance) of a sheet
> Dim ColLtrControlNumber As String 'Column Letter(s) of Control Numbers
> Dim ColLtrControlDescrip As String 'Column Letter(s) of Control
> Description
> Dim ColLtrControlBy As String 'Column Letter(s) of Control Owner
> Dim ColLtrRiskNumber As String 'Column Letter(s) of Risk Number
> Dim Continue As Boolean
> Dim Counter As Long
> ' Must have the Data source workbook open and the filter ranges set
> '
> Continue = True
> Do While Continue = True
> On Error Resume Next
> myOrigSheetProtectStatus = ActiveSheet.ProtectContents
> If myOrigSheetProtectStatus = True Then
> ActiveSheet.Protect UserInterfaceOnly:=True
> End If
> If Error Then
> If MsgBox("There is no Active Worksheet ......... Exiting Routine
> ..", vbOKOnly, _
> "NOTICE") = vbOK Then Exit Sub
> End If
> Set DataSourceBook = ActiveWorkbook
> Set DataSourceSheet = ActiveSheet
> '
> 'Note: Worksheet Tab names are limited to 31 characters. The
> process below, adds 7
> ' characters to the source tab name, (i.e." GAP nn") therefore the
> original tab name can not
> ' exceed 24 characters
> '
> If Len(DataSourceSheet.Name) > 24 Then
> MsgBox ("NOTE: The Data-Source Tab Label [" &
> DataSourceSheet.Name & _
> "] will be truncated to 24 Characters!!")
> End If
> DataSourceSheetName = Trim(Mid(DataSourceSheet.Name, 1, 24))
> DataSourceSheet.Name = DataSourceSheetName
> CopyFromSheetName = "GAP Template"
> CopyFromSheetNameOrig = "GAP Template"
> ' Determines the path of the Data source workbook and saves it as a
> variable
> ' to use below
> DataSourcePath = DataSourceBook.Path
> DataSourceBookName = DataSourceBook.Name
> ' Opens up the workbook from which the one and only W/S will become
> a "template" for use below
> DataSourceBookName = InputBox("Enter the complete File Name
> including the Extension" & Chr(10) _
> & "of the File from which the data will come", ,
> DataSourceBookName)
> If DataSourceBookName = "" Then
> MsgBox "Valid Data not Entered - CANCELLED!"
> Exit Sub
> End If
> ReceiveBookName = InputBox("Enter the complete File Name including
> the Extension" & Chr(10) & _
> "of the File into which the data will go" & Chr(10) & Chr(10) &
> "NOTE: The first Sheet in " & _
> "the ReceiveBook will be the Template", , ReceiveBookName)
> If ReceiveBookName = "" Then
> MsgBox "Valid Data not Entered - CANCELLED!"
> Exit Sub
> End If
> CopyFromBookName = InputBox("Enter the complete File Name including
> the Extension" & Chr(10) & _
> "of the File ""Template"" to Copy From", , CopyFromBookName)
> CopyFromSheetName = InputBox("Enter the SHEET Name to be copied in
> the File 'Template' to" & _
> "Copy From", , CopyFromSheetName)
> Set CopyFromBook = Nothing
> On Error Resume Next
> Set CopyFromBook = Workbooks(CopyFromBookName)
> On Error GoTo 0
> If CopyFromBook Is Nothing Then
> Set CopyFromBook = Workbooks.Open(fileName:=DataSourcePath & "\"
> & CopyFromBookName)
> End If
> Set ReceiveBook = Nothing
> On Error Resume Next
> Set ReceiveBook = Workbooks(ReceiveBookName)
> On Error GoTo 0
> If ReceiveBook Is Nothing Then
> Set ReceiveBook = Workbooks.Open(fileName:=DataSourcePath &
> "\" & ReceiveBookName)
> If Error Then
> Workbooks.Add
> Workbooks("Book1").SaveAs (DataSourcePath & "\" &
> ReceiveBookName)
> End If
> On Error GoTo 0
> End If
> ' ReceiveBook should have THE FIRST sheet cloned as a template.
> DataSourceBook.Activate
> DataSourceSheet.Activate
> On Error Resume Next
> With DataSourceSheet.AutoFilter.Range
> Set VisibleRowsRange = Nothing
> On Error Resume Next
> Set VisibleRowsRange = .Columns(1).Cells.Resize(.Rows.count - 1,
> 1).Offset(1, 0).SpecialCells(xlCellTypeVisible)
> On Error GoTo 0
> If VisibleRowsRange Is Nothing Then
> 'only the header is visible
> MsgBox " No filtered details
> shown !!!" + Chr(10) + Chr(10) + _
> "The Template W/S must be Active when you start this Macro"
> + Chr(10) + _
> "Also make sure that AutoFilter is actively filtering one
> Column"
> Else
> VisibleRowsCounter = 0
> ' Note: the range is one-cell wide. Thus VisibleRowsCounter
> will increment until = number of rows
> For Each MyCell In VisibleRowsRange.Cells
> VisibleRowsCounter = VisibleRowsCounter + 1
> Dim WSName As String
> WSName = DataSourceSheetName & " GAP " &
> VisibleRowsCounter
> If WorksheetExists(WSName, ReceiveBook) Then
> If MsgBox("Be aware that you may be duplicating
> worksheets!" + Chr(10) & Chr(10) & _
> "Do you wish to Continue?", vbYesNo) = vbNo Then
> Exit Sub
> CopyFromSheetName = WSName
> Else
> If WorksheetExists("GAP Template", ReceiveBook) Then
> CopyFromSheetName = "GAP Template"
> ' Do not wish to count the Template w/s
> VisibleRowsCounter = VisibleRowsCounter - 1
> Else
> MsgBox ("Add a Worksheet to Copy From and Name
> it 'GAP Template'")
> Exit Sub
> End If
> End If
> ReceiveBook.Worksheets.Add
> After:=ReceiveBook.Worksheets(ReceiveBook.Sheets.count)
> VisibleRowsCounter = VisibleRowsCounter + 1
> NewSheetName = ReceiveBook.ActiveSheet.Name
> ReceiveBook.Sheets(NewSheetName).Activate
> Counter = VisibleRowsCounter
> 'This loop checks if there is a worksheet with the same
> name
> Do While WorksheetExists(DataSourceSheetName & " GAP " &
> Counter, ReceiveBook)
> Counter = Counter + 1
> Loop
> ReceiveBook.Sheets(NewSheetName).Name =
> DataSourceSheetName & " GAP " & Counter
> ReceiveSheetName = DataSourceSheetName & " GAP " & Counter
> ' On Error Resume Next
> ReceiveBook.ActiveSheet.Name = ReceiveSheetName
> CopyFromBook.Worksheets(CopyFromSheetName).Activate
> Cells.Copy
> ReceiveBook.Worksheets(ReceiveSheetName).Activate
> ReceiveBook.Worksheets(ReceiveSheetName).Select
> Cells.Select
> Selection.PasteSpecial Paste:=xlPasteFormats,
> Operation:=xlNone, _
> SkipBlanks:=False, Transpose:=False
> ReceiveBook.Worksheets(ReceiveSheetName).Paste
> CopyFromBook.Worksheets(CopyFromSheetName).Activate
> Cells.Copy
> ReceiveBook.Worksheets(ReceiveSheetName).Activate
> ReceiveBook.Worksheets(ReceiveSheetName).Select
> Cells.Select
> ReceiveBook.Worksheets(ReceiveSheetName).Paste
> Application.CutCopyMode = False
> DataSourceBook.Activate
> If VisibleRowsCounter < 3 Then
> ColLtrControlNumber = Trim(InputBox("Control
> Number", "Enter Column Letter(s) of:", "K"))
> ColLtrControlDescrip = Trim(InputBox("Actual
> Control", "Enter Column Letter(s) of:", "L"))
> ColLtrControlBy = Trim(InputBox("Control Performed
> By", "Enter Column Letter(s) of:", "O"))
> ColLtrRiskNumber = Trim(InputBox("Risk Number",
> "Enter Column Letter(s) of:", "G"))
> End If
> Sheets(1).Activate
> Call ABBOneCellText
> ReceiveBook.Worksheets(ReceiveSheetName).Activate
> ActiveSheet.Range("A4").Value = Mid(DataSourceBookName,
> 1, 12)
> ActiveSheet.Range("A4").Font.ColorIndex = 5
> ActiveSheet.Range("A6").Value = TextVar
> ActiveSheet.Range("A6").Font.ColorIndex = 5
> ActiveSheet.Range("A8").Formula = "=MID('[" &
> DataSourceBookName & "]" & _
> DataSourceSheetName & "'!" & ColLtrControlNumber &
> MyCell.Cells.Row & ",1,1)" '
> ActiveSheet.Range("A8").Font.ColorIndex = 5
> ActiveSheet.Range("A10").Formula = "='[" &
> DataSourceBookName & "]" & _
> DataSourceSheetName & "'!" & ColLtrControlDescrip &
> MyCell.Cells.Row
> ActiveSheet.Range("A10").Font.ColorIndex = 5
> ActiveSheet.Range("D4").Value = Mid(Now(), 1, 10)
> ActiveSheet.Range("D4").Font.ColorIndex = 5
> ActiveSheet.Range("F4").Formula = "='[" &
> DataSourceBookName & "]" & _
> DataSourceSheetName & "'!" & ColLtrControlBy &
> MyCell.Cells.Row
> ActiveSheet.Range("F4").Font.ColorIndex = 5
> ActiveSheet.Range("F8").Formula = "='[" &
> DataSourceBookName & "]" & _
> DataSourceSheetName & "'!" & ColLtrRiskNumber &
> MyCell.Cells.Row
> ActiveSheet.Range("F8").Font.ColorIndex = 5
> ActiveSheet.Range("I4").Formula = "='[" &
> DataSourceBookName & "]" & _
> DataSourceSheetName & "'!" & ColLtrControlNumber &
> MyCell.Cells.Row
> ActiveSheet.Range("I4").Font.ColorIndex = 5
> ReceiveBook.Worksheets(ReceiveSheetName).Select
> Cells.Select
> With Selection
> .Copy
> .PasteSpecial Paste:=xlPasteValues,
> Operation:=xlNone, SkipBlanks:=False, Transpose:=False
> End With
> Application.CutCopyMode = False
> Range("A1").Select
> Next MyCell
> End If
> End With
> If myOrigSheetProtectStatus = True Then
> DataSourceSheet.Protect UserInterfaceOnly:=False
> End If
> If MsgBox("Press YES to Continue Processing Sheets", vbYesNo) = vbNo

Dave Peterson · 07-29-2005, 08:05 PM

Glad you got it working the way you wanted.

(I don't envy your job with that SOX stuff.)

Dennis wrote:
>
> Dave, (I hope that you read this!)
>
> It took me a while to "perfect" this procedure. Obviously I am not that
> good with VBA. Saying that, this procedure and call to another works very
> well as intended.
>
> As an accountant, my real work is accounting, audit, and Sarbanes-Oxley
> (SOX) tasks. VBA is my hobby.
<<snipped>>

Dennis · 07-29-2005, 09:05 PM

In two years of work with SOX, I found it very difficult to find people with
a smile.

Thanks again!

Dennis

"Dave Peterson" wrote:

> Glad you got it working the way you wanted.
>
> (I don't envy your job with that SOX stuff.)
>
> Dennis wrote:
> >
> > Dave, (I hope that you read this!)
> >
> > It took me a while to "perfect" this procedure. Obviously I am not that
> > good with VBA. Saying that, this procedure and call to another works very
> > well as intended.
> >
> > As an accountant, my real work is accounting, audit, and Sarbanes-Oxley
> > (SOX) tasks. VBA is my hobby.
> <<snipped>>
>

Inserting Filtered RC cell information into other worksheets

LinkBack

Thread Tools

Rate This Thread

Display

Inserting Filtered RC cell information into other worksheets

Re: Inserting Filtered RC cell information into other worksheets

Re: Inserting Filtered RC cell information into other worksheets

Re: Inserting Filtered RC cell information into other worksheets

Re: Inserting Filtered RC cell information into other worksheets

Re: Inserting Filtered RC cell information into other worksheets

Re: Inserting Filtered RC cell information into other worksheets

Re: Inserting Filtered RC cell information into other worksheets

Re: Inserting Filtered RC cell information into other worksheets

Re: Inserting Filtered RC cell information into other worksheets

Re: Inserting Filtered RC cell information into other worksheets

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions