Macro is worng

Microsoft Excel 2003 (full)
March 19, 2010 at 01:51:10
Specs: Windows XP
HI,

Can some one tell me whats worng in this macro please.


C2 = .[sheet1!A1] & "|" & .[sheet1!A2] & "|" & .[sheet2!B1] & "|" & .[sheet1!B2] & "|" & .[sheet3!A1] & "|" & .[sheet3!B1] & "|" & .[sheet4!B1] & "|" & .[sheet4!B2] & "|" & .[sheet5!B1] & "|" & Join(WorksheetFunction.Transpose(.[sheets6!A1:A9]), "|||")

Thank you in Advance


See More: Macro is worng

Report •


#1
March 19, 2010 at 01:52:11
Sorry i couldnt edit in anymore here is the compleet code
Sub apart()
  Dim C2 As Variant
    With Workbooks.Open("C:\test.xls")
    C2 = .[sheet1!A1] & "|" & .[sheet1!A2] & "|" & .[sheet2!B1] & "|" & .[sheet1!B2] & "|" & .[sheet3!A1] & "|" & .[sheet3!B1] & "|" & .[sheet4!B1] & "|" & .[sheet4!B2] & "|" & .[sheet5!B1] & "|" & Join(WorksheetFunction.Transpose(.[sheets6!A1:A9]), "|||")
    .Close
  End With
  ThisWorkbook.Sheets(1).Cells(1, 1).Resize(, UBound(Split(C2, "|")) + 1) = Split(C2, "|")
End Sub


Report •

#2
March 19, 2010 at 06:16:25
Hi,

You haven't said what the macro is meant to achieve -
It would be helpful to know what are you trying to do.

With the macro itself I can see a number of issues, which I can list, but it would be better to start from scratch, rather than try and fix this macro.

1. You have declared C2 as a single variable, not as an array and your code includes UBound attempting to refer to C2. UBound is used with an array to return it's size.
It is possible to assign an array to a variant variable, but you can't create an array by passing it a string.
Arrays are DIM'd like this: C2(n) where n is the number of elements in the array.

2. You have DIM'd C2 as a variant, but as you appear to only be assigning Text to it, it would be better to assign it as a String variable, not as a variant

3. You have attempted to pass a string consisting of the contents of several cells with intervening "|" characters.
Your references to the cells such as .[sheet1!A1] are wrong. You are using a notation that is found in worksheet cells and is not used in VBA.
Refer to cells inside a With statement like this: .Worksheets("Sheet1").Range("A1").Value
(.Value is the default for a single cell range and is not strictly necessary and is not required for the copy operation which copies all the cells components, not just it's value). If copying Text then .Worksheets("Sheet1").Range("A1").Text is appropriate.

4.If you want the contents of the cells Sheet1 A1 etc in an array then you will have to assign each cell's contents to a numbered array element: C2(0)= .Worksheets("Sheet1").Range("A1").Value

5. It appears that you are trying to use Join to add cell contents to C2, but Join is for concatenating (joining) elements of an array into a single string

6. Resize requires two variables - row and column but you have nothing for the column variable: Resize (,UBound(Split(C2, "|")) + 1). There should be a number for rows between the ( and the ,

7. I don't think that you can assign an array to a range of cells using Split (but I may be wrong).

8. I notice that refer to the source worksheet names as sheet1 etc. Unless you have renamed the worksheets they should be Sheet1 etc. You also have sheets6 which should likely be Sheet6

9. You have used the Worksheet Transpose function, when there already is a Transpose function in VBA (see example that follows)

Different programmers tend to have different styles, and may use different approaches to solving the same issue, and as a result it is not appropriate to criticize programming styles just because they do not match your own style.

However in this case, I would say that you appear to have taken a very complicated route to doing what appears to be a straightforward copy and paste operation.

From the code that you have supplied it appears that you are trying to copy data from a series of cells in the Workbook "Test.xls" (Sheet1 cell A1 etc). to Sheet 1, starting at Cell A1 in the workbook that contains the macro. ThisWorkbook specifically refers to the workbook that contains the macro.

Here is a macro that does a series of copy and pastes:

Option Explicit

Sub Apart()
Dim WBDest As Range

On Error GoTo ErrHnd

'Open the source workbook
Workbooks.Open ("C:\temp\Temp.xls")

'create a starting point range for pasting the copied cells to
Set WBDest = ThisWorkbook.Worksheets(1).Range("A1")

'turn off screen updating  to stop flicker and increase speed
Application.ScreenUpdating = False

'copy and paste the relevant cells
With Workbooks("Temp.xls")
    'single cell copy/paste operations
    .Worksheets("Sheet1").Range("A1").Copy Destination:=WBDest.Offset(0, 0)
    .Worksheets("Sheet1").Range("A2").Copy Destination:=WBDest.Offset(0, 1)
    .Worksheets("Sheet2").Range("B1").Copy Destination:=WBDest.Offset(0, 2)
    .Worksheets("Sheet2").Range("B2").Copy Destination:=WBDest.Offset(0, 3)
    .Worksheets("Sheet3").Range("A1").Copy Destination:=WBDest.Offset(0, 4)
    .Worksheets("Sheet3").Range("B1").Copy Destination:=WBDest.Offset(0, 5)
    .Worksheets("Sheet4").Range("B1").Copy Destination:=WBDest.Offset(0, 6)
    .Worksheets("Sheet4").Range("B2").Copy Destination:=WBDest.Offset(0, 7)
    .Worksheets("Sheet5").Range("B1").Copy Destination:=WBDest.Offset(0, 8)
    'copy and paste a range of cells with transposition
    .Worksheets("Sheet6").Range("A1:A9").Copy
    'only need identify the first destination cell when copying a range
    WBDest.Offset(0, 9).PasteSpecial Paste:=xlPasteAll, Transpose:=True
End With

'close the source workbook without saving it (this macro made no changes to it)
Workbooks("Temp.xls").Close SaveChanges:=False

'restore screen updating
Application.ScreenUpdating = True

Exit Sub

'error handling
ErrHnd:
Err.Clear
Application.ScreenUpdating = True
End Sub

Regards


Report •

#3
March 23, 2010 at 01:22:56
Well humar,

This code is another version of what you have made for me. Down here. But the point is that i can't get two emypt cells between each Sheet6 A1. You told me what the do, but i still didnt get it, so I ask some one else to look at it and they give me the upperhead code.

Option Explicit
Sub GetScans()
Dim strFirstScan As String
Dim strSecondScan As String
Dim strLastScan As String
Dim blnRedo As Boolean
Dim strPath As String
Dim strBase As String
Dim strThisFilename As String
Dim strThisFile As String
Dim strDestFN As String
Dim intDestRowOffset As Integer
Dim intDestColOffset As Integer
Dim n As Integer

On Error GoTo ErrHnd

'stop screen flicker during copy and paste operations
Application.ScreenUpdating = False

'setup name of destination file - use the name of this workbook
strDestFN = ActiveWorkbook.Name

'setup Path to saved scan files - must end with \
strPath = "C:\Temp\"

'setup base name for scanned files (case sensitive)
strBase = "scans_"

'set first row offset for saving data (Offset 0 is row 1)
intDestRowOffset = 1

'get number of scan files
FirstS:
strFirstScan = InputBox("Enter first scan file number (4 digits)" & vbCrLf _
                       & "or enter 'Q' to quit", "First Scan")
'test that text is a four character string representing a number
blnRedo = False
If Len(strFirstScan) <> 4 Or Not IsNumeric(strFirstScan) Then
    If strFirstScan = "Q" Or strFirstScan = "q" Then
        Exit Sub
        Else
        blnRedo = True
    End If
End If
'redo first number entry
If blnRedo = True Then GoTo FirstS

SecondS:
strSecondScan = InputBox("Enter Second scan file number (4 digits)" & vbCrLf _
                        & "or enter 'Q' to quit", "Second Scan")
'test that text is a four character string representing a number
blnRedo = False
If Len(strSecondScan) <> 4 Or Not IsNumeric(strSecondScan) Then
    If strSecondScan = "Q" Or strSecondScan = "q" Then
        Exit Sub
        Else
        blnRedo = True
    End If
End If
'redo Second number entry
If blnRedo = True Then GoTo SecondS

'open each scan file in turn and copy information
For n = CInt(strFirstScan) To CInt(strSecondScan)
    'set destination column offset for first column (0 = "A")
    intDestColOffset = 0
    'create file name
    strThisFilename = strBase & Format(n, "0000") & ".xls"
    strThisFile = strPath & strThisFilename
    'open this file
    Application.Workbooks.Open (strThisFile)
    With Workbooks(strThisFilename)
        .Worksheets("Sheet1").Range("A1:B1").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 2
        .Worksheets("Sheet2").Range("B1").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 1
        .Worksheets("Sheet2").Range("B2").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 1
        .Worksheets("Sheet3").Range("A1:B1").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 2
        .Worksheets("Sheet4").Range("B1").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 1
        .Worksheets("Sheet4").Range("B2").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 1
        .Worksheets("Sheet5").Range("B1").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 1
        .Worksheets("Sheet6").Range("A1:A9").Copy
        Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset).PasteSpecial _
            Paste:=xlPasteAll, Transpose:=True
    End With
    'next row
   intDestRowOffset = intDestRowOffset + 1
   'close current source file
   Workbooks(strThisFilename).Close SaveChanges:=False
Next n

'save this Destination workbook
Workbooks(strDestFN).Save

'reinstate screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'reinstate screen updating
Application.ScreenUpdating = True
End Sub


Report •

Related Solutions

#4
March 23, 2010 at 05:52:07
Hi,

If I understand correctly, you want two empty cells between each of the cells copied from Sheet6 (A1 to A9)

Here are the first 3 copied cells:

J	K	L	M	N	O	P
A1			A2			A3

Replace

        .Worksheets("Sheet6").Range("A1:A9").Copy
        Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset).PasteSpecial _
            Paste:=xlPasteAll, Transpose:=True

with
        'copy Sheet6 A1 to A9 but leave two blank cells between each copied cell
        For m = 0 To 8
        'copy offset 'm' is rows as range is vertical
        .Worksheets("Sheet6").Range("A1").Offset(m, 0).Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        'leave 2 empty cells between each copied cell
        intDestColOffset = intDestColOffset + 3
        Next m

You will also need to add:

Dim m as integer

Regards

Report •

#5
March 23, 2010 at 06:56:55
aa your are kind Humar.

It works. :) Thank agian

Here is the compleet code for the users who are looking for something like this

Option Explicit
Sub GetScansgood1()
Dim strFirstScan As String
Dim strSecondScan As String
Dim strLastScan As String
Dim blnRedo As Boolean
Dim strPath As String
Dim strBase As String
Dim strThisFilename As String
Dim strThisFile As String
Dim strDestFN As String
Dim intDestRowOffset As Integer
Dim intDestColOffset As Integer
Dim n As Integer
Dim m As Integer

On Error GoTo ErrHnd

'stop screen flicker during copy and paste operations
Application.ScreenUpdating = False

'setup name of destination file - use the name of this workbook
strDestFN = ActiveWorkbook.Name

'setup Path to saved scan files - must end with \
strPath = "C:\Temp\"

'setup base name for scanned files (case sensitive)
strBase = "scans_"

'set first row offset for saving data (Offset 0 is row 1)
intDestRowOffset = 1

'get number of scan files
FirstS:
strFirstScan = InputBox("Enter first scan file number (4 digits)" & vbCrLf _
                       & "or enter 'Q' to quit", "First Scan")
'test that text is a four character string representing a number
blnRedo = False
If Len(strFirstScan) <> 4 Or Not IsNumeric(strFirstScan) Then
    If strFirstScan = "Q" Or strFirstScan = "q" Then
        Exit Sub
        Else
        blnRedo = True
    End If
End If
'redo first number entry
If blnRedo = True Then GoTo FirstS

SecondS:
strSecondScan = InputBox("Enter Second scan file number (4 digits)" & vbCrLf _
                        & "or enter 'Q' to quit", "Second Scan")
'test that text is a four character string representing a number
blnRedo = False
If Len(strSecondScan) <> 4 Or Not IsNumeric(strSecondScan) Then
    If strSecondScan = "Q" Or strSecondScan = "q" Then
        Exit Sub
        Else
        blnRedo = True
    End If
End If
'redo Second number entry
If blnRedo = True Then GoTo SecondS

'open each scan file in turn and copy information
For n = CInt(strFirstScan) To CInt(strSecondScan)
    'set destination column offset for first column (0 = "A")
    intDestColOffset = 0
    'create file name
    strThisFilename = strBase & Format(n, "0000") & ".xls"
    strThisFile = strPath & strThisFilename
    'open this file
    Application.Workbooks.Open (strThisFile)
    With Workbooks(strThisFilename)
        .Worksheets("Sheet1").Range("A1:B1").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 2
        .Worksheets("Sheet2").Range("B1").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 1
        .Worksheets("Sheet2").Range("B2").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 1
        .Worksheets("Sheet3").Range("A1:B1").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 2
        .Worksheets("Sheet4").Range("B1").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 1
        .Worksheets("Sheet4").Range("B2").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 1
        .Worksheets("Sheet5").Range("B1").Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        intDestColOffset = intDestColOffset + 1
    'copy Sheet6 A1 to A9 but leave two blank cells between each copied cell
        For m = 0 To 8
        'copy offset 'm' is rows as range is vertical
        .Worksheets("Sheet6").Range("A1").Offset(m, 0).Copy _
            Destination:=Workbooks(strDestFN).Worksheets("Sheet1").Range("A1"). _
            Offset(intDestRowOffset, intDestColOffset)
        'leave 2 empty cells between each copied cell
        intDestColOffset = intDestColOffset + 3
        Next m
    End With
    'next row
   intDestRowOffset = intDestRowOffset + 1
   'close current source file
   Workbooks(strThisFilename).Close SaveChanges:=False
Next n

'save this Destination workbook
Workbooks(strDestFN).Save

'reinstate screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'reinstate screen updating
Application.ScreenUpdating = True
End Sub


Report •

#6
March 23, 2010 at 07:38:47
Hi,

You're welcome.

Regards

Humar


Report •

Ask Question