Copy contents of cells if cell contains information

  • Thread starter That's Confidential
  • Start date
T

That's Confidential

I have a column of cells, say A1:A30 in a few different spreadsheets. Some
of these spreadsheets contain information within these cells (not formulae,
but just typed info) and some don't contain information.

Now, in a new spreadsheet, I would like to copy the contents of these cells
(columns) if there is information in them.

So for example, in spreadsheet 1, i have information, speadsheet 2 i don't,
spreadsheet 3 I do, i would like my information to be copied into a new cell
as follows:-

information 1
information 2

Any advice?

Thanks
 
J

jeff

Hi,

Test this on sample (or backed-up) workbooks.
just paste in as your "Sheet1" macro.

Modified slightly from "BrianB"'s post:
"BrianB >" <<[email protected]> Sent:
4/27/2004 7:52:33 AM

jeff


'==============================================
'- Generic code for transferring data from
'- one or more workbooks in a folder to a master sheet
'-
'- workbooks must be the only ones in the folder
'- run this code from the master book
'-
'----------------------------------------------
Dim ToBook As String
Dim ToSheet As Worksheet
Dim NumColumns As Integer
Dim ToRow As Long
Dim FromBook As String
Dim FromSheet As Worksheet
Dim FromRow As Long
Dim LastRow As Long
'-
'----------------
Sub NEW_MASTER()
'----------------
Application.Calculation = xlCalculationManual
ChDrive ActiveWorkbook.Path
ChDir ActiveWorkbook.Path
ToBook = ActiveWorkbook.Name
Set ToSheet = ActiveWorkbook.Worksheets(1)
NumColumns = ToSheet.Range("A1").End(xlToRight).Column
ToRow = ToSheet.Range("A65536").End(xlUp).Row
'- clear master
If ToRow <> 1 Then
ToSheet.Range(Cells(2, 1), Cells(ToRow,
NumColumns)).ClearContents
End If
ToRow = 2
'- main loop
FromBook = Dir("*.xls")
While FromBook <> ""
If FromBook <> ToBook Then
Application.StatusBar = FromBook
Transfer_data
End If
FromBook = Dir
Wend
'-- close
MsgBox ("Done.")
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
End Sub
'-------------------------------------------------

Sub Transfer_data()
Workbooks.Open Filename:=FromBook
For Each FromSheet In Workbooks(FromBook).Worksheets
LastRow = FromSheet.Range("A65536").End(xlUp).Row
'- copy paste
a1$ = FromSheet.Cells(2, 1).Address
b1$ = FromSheet.Cells(LastRow, NumColumns).Address
FromSheet.Range(a1$ & ":" & b1$).Copy _
Destination:=ToSheet.Range("A" & ToRow)
'- set next ToRow
ToRow = ToSheet.Range("A65536").End(xlUp).Row + 1
Next
Workbooks(FromBook).Close savechanges:=False
End Sub
'==== EOP ======================================
 
Top