1

I will keep this quick. The attached code for the most part works i have used slight variations of it on other projects. the commented out range3.copy is from my last project.

I am currently having issues getting selection.copy to copy the selected range in the correct workbook. I have tried many things some are noted in the script. but I can not get the selection.copy to work .range.copy will work and populate the clipboard. But I have not figured out how to pastespecial using .copy.

I tried outputting to variable .. didn't work as i thought it might. I feel I have to be missing something on the workbook selection/activation but I don't know what. Thanks in advance for any advice or assistance .. I will continue plugging away and see if I can figure it out.

Here is the first segment with the issue. SRCrange1.select then selection.copy does not actually copy the designated selection. The full code is below.

      Dim MyColumn As String
    Dim Here As String
    Dim AC As Variant

     'SRCrange1.copy  ': This will copy to clipboard

       'objworkbook.Worksheets("plan").Range("b6:h7").Select  no change from SRCrange1.select
       'SRCrange1.Select 'the range does select
        'Selection.copy  '  this will cause a activecell in DSTwb _
        to be copied neither direct reference to SRCrange1.select or .avtivate will change that.


DSTwb.Select
             DSTwb.Range("b2").Select
             Here = ActiveCell.Address
             MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
             Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
             lastrow.Select
             Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

FULL CODE 

Sub parse()
Dim strPath As String
Dim strPathused As String


'On Error Resume Next


Set objexcel = CreateObject("Excel.Application")
objexcel.Visible = True
objexcel.DisplayAlerts = False
strPath = "C:\prodplan"
Set objfso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objfso.GetFolder(strPath)


'Loop through objWorkBooks
For Each objfile In objFolder.Files

    If objfso.GetExtensionName(objfile.Path) = "xlsx" Then
        Set objworkbook = objexcel.Workbooks.Open(objfile.Path)
                                ' Set path for move to at end of script
                                strPathused = "C:\prodplan\used\" & objworkbook.Name

'open WB to consolidate too
                        Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"

'Range management sourcebook
        Set SRCwb = objworkbook.Worksheets("plan")
        Set SRCrange1 = objworkbook.Worksheets("plan").Range("b6:i7")
        Set SRCrange2 = objworkbook.Worksheets("plan").Range("k6:p7")
        'Set SRCrange3 = objworkbook.Worksheets("").Range("")

'Range management sourcebook
        Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")
        'Set DSTrange1 = Workbooks("plancon.xlsx").Worksheets("data").Range("")
        'Set DSTrange2 = Workbooks("plancon.xlsx").Worksheets("data").Range("")
        'Set DSTrange3 = Workbooks("plancon.xlsx").Worksheets("data").Range("")

'start header dates and shifts copy from objworkbook to consolidated WB
                SRCwb.Select
                'On Error Resume Next
                'SRCwb.Cells.UnMerge

Dim MyColumn As String
Dim Here As String
Dim AC As Variant

 'SRCrange1.copy  ': This will copy to clipboard

   'objworkbook.Worksheets("plan").Range("b6:h7").Select  no change from SRCrange1.select
   'SRCrange1.Select 'the range does select
    'Selection.copy  '  this will cause a activecell in DSTwb _
    to be copied neither direct reference to SRCrange1.select or .avtivate will change that.
         DSTwb.Select
         DSTwb.Range("b2").Select
         Here = ActiveCell.Address
         MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
         Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
         lastrow.Select
         Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True


   SRCrange2.Select
    Selection.copy
         Workbooks("plancon.xlsx").Worksheets("sheet1").Select
         ActiveSheet.Range("b2").Select
         ActiveSheet.Range("b2").Activate
         Here = ActiveCell.Address
         MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
         Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
         lastrow.Select
         Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

'    range3.copy
'         Workbooks("data.xlsx").Worksheets("sheet1").Activate
'         ActiveSheet.Range("c2").Select
'         ActiveSheet.Range("c2").Activate
'         Here = ActiveCell.Address
'         MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
'         Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
'         ActiveSheet.Paste Destination:=lastrow


                    'start loop for objworkbook name copy to field in plancon corisponding with date/shift and copy/paste select row data.

    objworkbook.Close False
                        'Move proccesed file to new Dir

    OldFilePath = objfile 'original file location
        NewFilePath = strPathused ' new file location
            Name OldFilePath As NewFilePath ' move the file

End If

Next

objexcel.Quit




End Sub
4

3 回答 3

3

First, a relative welcome to SO!

Second, some tips for you that will make life easier in VBA programming:

  1. Use Option Explicit and always Dimension and Declare your variable types.
  2. When naming variables, make them easy to understand and follow. So, if you are going to create a worksheet variable, call it something like wksCopy. Or, if you are going to name a workbook, call it wkbCopyTo
  3. You don't need to use .Select and .Activate, but rather you can work directly with your objects. Also, by declaring the appropriate variables types, this make it much easier to work with these objects in your code each time you need them.
  4. I don't know if you are running this code inside Excel, or another application (like Access), but if you are in Excel, there is no need to create an Excel object, as you can work with the Excel App directly. Ignore this if you are using Access / Word / PPT etc to fire the code.

All these tips make your code much easier to read and understand and follow when trying to debug, and write.

All that said, I have refactored your code above to incorporate most of these principles (I kept all your variable names intact so you wouldn't get lost in any re-namings.) If this re-write doesn't directly solve your problem = which it may not, because the code is kind of confusing to me as written, I think it will be much easier for you to follow and understand and find out where it's not doing what you expect when you debug. Also, I think it will help us help you if you can't figure it out.

Sub parse()

    Dim strPath As String, strPathused As String
    Dim objexcel As Excel.Application

    Set objexcel = CreateObject("Excel.Application")
    With objexcel
        .Visible = True
        .DisplayAlerts = False
    End With

    strPath = "C:\prodplan"

    Dim objfso As FileSystemObject, objFolder As Folder

    Set objfso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objfso.GetFolder(strPath)


    'Loop through objWorkBooks
    For Each objfile In objFolder.Files

        If objfso.GetExtensionName(objfile.Path) = "xlsx" Then

            Dim objWorkbook As Excel.Workbook
            Set objWorkbook = objexcel.Workbooks.Open(objfile.Path)

            ' Set path for move to at end of script
            strPathused = "C:\prodplan\used\" & objWorkbook.Name

            'open WB to consolidate too
            objexcel.Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"

            'Range management sourcebook
            Dim SRCwb As Excel.Worksheet, SRCrange1 As Excel.Range, SRCrange2 As Excel.Range

            Set SRCwb = objWorkbook.Worksheets("plan") 'sjh -> to me wb implies wb, but you set it to a worksheet (could be a style thing, but worth pointing out
            Set SRCrange1 = objWorkbook.Worksheets("plan").Range("b6:i7")
            Set SRCrange2 = objWorkbook.Worksheets("plan").Range("k6:p7")


            'Range management sourcebook
            Set DSTwb = Excel.Worksheet
            Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")

            'start header dates and shifts copy from objworkbook to consolidated WB
            Dim MyColumn As String
            Dim Here As String
            Dim AC As Variant

            Here = DSTwb.Range("B2").Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)

            'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook
            Dim lastrow As Range
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange1.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            Here = Workbooks("plancon.xlsx").Worksheets("sheet1").Range("B2").Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)


            'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange2.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            objWorkbook.Close False

            'Move proccesed file to new Dir

            OldFilePath = objfile 'original file location
            NewFilePath = strPathused ' new file location
            Name OldFilePath As NewFilePath ' move the file

        End If

    Next

objexcel.Quit

End Sub

UPDATE If you are running this all in Excel. Just use this code below. I left both codes in my answer, in case you are not running this from Excel.

Option Explicit

Sub parse()

    Application.DisplayAlerts = False

    Dim strPath As String, strPathused As String
    strPath = "C:\prodplan"

    Dim objfso As FileSystemObject, objFolder As Folder

    Set objfso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objfso.GetFolder(strPath)


    'Loop through objWorkBooks
    For Each objfile In objFolder.Files

        If objfso.GetExtensionName(objfile.Path) = "xlsx" Then

            Dim objWorkbook As Workbook
            Set objWorkbook = Workbooks.Open(objfile.Path)

            ' Set path for move to at end of script
            strPathused = "C:\prodplan\used\" & objWorkbook.Name

            'open WB to consolidate too
            Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"

            'Range management sourcebook
            Dim SRCwb As Worksheet, SRCrange1 As Range, SRCrange2 As Range

            Set SRCwb = objWorkbook.Worksheets("plan")
            Set SRCrange1 = SRCwb.Range("b6:i7")
            Set SRCrange2 = SRCwb.Range("k6:p7")

            'Range management sourcebook
            Dim DSTwb As Worksheet
            Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")

            'start header dates and shifts copy from objworkbook to consolidated WB
            Dim MyColumn As String
            Dim Here As String
            Dim AC As Variant

            Here = DSTwb.Range("B2").Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)

           'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook or the other workbook you have open
            Dim lastrow As Range
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange1.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            Here = Workbooks("plancon.xlsx").Worksheets("sheet1").Range("B2").Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)

           'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook or the other workbook you have open
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange2.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            objWorkbook.Close False

            'Move proccesed file to new Dir

            OldFilePath = objfile 'original file location
            NewFilePath = strPathused ' new file location
            Name OldFilePath As NewFilePath ' move the file

        End If

    Next

End Sub
于 2012-06-20T19:58:31.130 回答
1

Just to add to the other answers: for contiguous ranges you don't need to use copy for this operation (pastespecial >> values + transpose) 

Sub CopyValuesTranspose()

    Dim rngCopy As Range, rngPaste As Range

    Set rngCopy = Range("A1:B10")
    Set rngPaste = Range("D1")

    rngPaste.Resize(rngCopy.Columns.Count, rngCopy.Rows.Count).Value = _
                                   Application.Transpose(rngCopy.Value)

End Sub
于 2012-06-20T23:53:02.423 回答
0

no need to select a range and then copy the selection, when you can copy a range directly:

objworkbook.Worksheets("plan").Range("b6:h7").Copy
same_or_different_Range.PasteSpecial Paste:=xlPasteValues, _
    operation:=xlNone, skipblanks:=False, Transpose:=True
于 2012-06-20T19:49:26.133 回答