isrisian
01-18-2011, 09:57 AM
I've been working on a piece of test code that opens another spread sheet, copies all the information in a particular column, then pastes that data back in the original spread sheet. Currently I’m also trying to add in the ability for the code to print “NA” in all the spaces where the work sheet being copied from is blank, such that if further worksheets are copied, the data all lines up in the composite sheet. I accomplish this by storing the length of the previous copied row in a variable OldRange, and then selecting the blank row out to this range, but it is in that line that I get an Error 1004 Application defined or object defined error. I’ve checked the line for the causes of this error that I’ve found on other forums but I have so far, been unsuccessful. Any help in correcting this problem would be greatly appreciated.
PS: the hi-lighted line is where the error occurs
Option Explicit
Sub Copy_Cells()
Dim FlNm As String
Dim wb As Workbook
Dim LR As Long
Dim cl As Integer
Dim name As String
Dim col As String
Dim colP As String
Dim ref As Integer
Dim iReply As Integer
Dim refN As String
Dim OldRange As Integer
OldRange = 0
begin:
'choose file
FlNm = Application.GetOpenFilename
If FlNm = "False" Or FlNm = "" Then Exit Sub
'open file
Set wb = Workbooks.Open(FlNm)
'
For ref = 1 To 4
'set columns to find
Select Case ref
Case 1
refN = "Apples"
Case 2
refN = "Cars"
Case 3
refN = "Sheep"
Case 4
refN = "Sand People"
End Select
'select column to copy to
For cl = 1 To 30
'Get name
name = ActiveSheet.Cells(1, cl)
If refN = name Then
col = ConvertToLetter(cl)
colP = ConvertToLetter(ref)
'copy data, add to current workbook at next empty cell in column A
With wb.Sheets("Sheet1")
If IsEmpty(ActiveSheet.Cells(2, col)) Then
ThisWorkbook.Sheets("Sheet1").Range(col & 2, col & OldRange).End(xlUp).Select
Selection = "NA"
Else
OldRange = Range(col & .Rows.Count).End(xlUp).Row
MsgBox OldRange
.Range(col & 2, .Range(col & .Rows.Count).End(xlUp)).Copy _
ThisWorkbook.Sheets("Sheet1").Range(colP & Rows.Count).End(xlUp).Offset(1)
End If
Exit For
End With
End If
Next cl
Next ref
'close opened file
wb.Close False
iReply = MsgBox(Prompt:="Would you like to add another file?", _
Buttons:=vbYesNoCancel)
If iReply = vbYes Then
GoTo begin
ElseIf iReply = vbNo Then
Exit Sub
Else 'They cancelled (VbCancel)
Exit Sub
End If
End Sub
Function ConvertToLetter(iCol As Integer) As String
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function
PS: the hi-lighted line is where the error occurs
Option Explicit
Sub Copy_Cells()
Dim FlNm As String
Dim wb As Workbook
Dim LR As Long
Dim cl As Integer
Dim name As String
Dim col As String
Dim colP As String
Dim ref As Integer
Dim iReply As Integer
Dim refN As String
Dim OldRange As Integer
OldRange = 0
begin:
'choose file
FlNm = Application.GetOpenFilename
If FlNm = "False" Or FlNm = "" Then Exit Sub
'open file
Set wb = Workbooks.Open(FlNm)
'
For ref = 1 To 4
'set columns to find
Select Case ref
Case 1
refN = "Apples"
Case 2
refN = "Cars"
Case 3
refN = "Sheep"
Case 4
refN = "Sand People"
End Select
'select column to copy to
For cl = 1 To 30
'Get name
name = ActiveSheet.Cells(1, cl)
If refN = name Then
col = ConvertToLetter(cl)
colP = ConvertToLetter(ref)
'copy data, add to current workbook at next empty cell in column A
With wb.Sheets("Sheet1")
If IsEmpty(ActiveSheet.Cells(2, col)) Then
ThisWorkbook.Sheets("Sheet1").Range(col & 2, col & OldRange).End(xlUp).Select
Selection = "NA"
Else
OldRange = Range(col & .Rows.Count).End(xlUp).Row
MsgBox OldRange
.Range(col & 2, .Range(col & .Rows.Count).End(xlUp)).Copy _
ThisWorkbook.Sheets("Sheet1").Range(colP & Rows.Count).End(xlUp).Offset(1)
End If
Exit For
End With
End If
Next cl
Next ref
'close opened file
wb.Close False
iReply = MsgBox(Prompt:="Would you like to add another file?", _
Buttons:=vbYesNoCancel)
If iReply = vbYes Then
GoTo begin
ElseIf iReply = vbNo Then
Exit Sub
Else 'They cancelled (VbCancel)
Exit Sub
End If
End Sub
Function ConvertToLetter(iCol As Integer) As String
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function