Trouble copying with multipleRange

nmgmarques · Mar 8, 2016

Hi all.

Working on one of my most complicated Excel files to date. I start with the disclaimer that I know nothing of Visual Basic and all the code you see below was cobbled together by scouring the web and mostly the forums here. The idea of the script is to save the file on button press, then send a selection of the file via mail, then copy relevant data over to a index file and finally print out a copy of the file.

Here is the code. I'm pasting it all here in case anyone can use some of it in the future for whatever reason. I believe in sharing the knowledge when possible

Please don't be put off by the size of the post as it's only the last portion that is giving me grief.

Code:
Sub SaveAndSend() Application.ScreenUpdating = False ' Gravar ficheiro com nome igual ao número de ECM e indicar se é Aplicável ****Dim IntNum**********As String ****Dim NumYear******** As String ****Dim FName********** As String ****Dim FPath********** As String ****Dim NApl************As String ****Dim sFileName****** As String ****Dim strbodySD****** As String ****Dim strbodyApl******As String ****Dim strbodyNApl**** As String **** ****FPath = "L:\10_CBR_Common\Assuntos gerais\Gestão ECM" ****IntNum = Sheets("ECM").Range("N4").Text ****NumYear = Sheets("ECM").Range("O4").Text ****FName = Sheets("ECM").Range("D6").Text ****NApl = Sheets("ECM").Range("S4").Text **** ****'ECM Sem Decisão para debate na reunião semanal e determinação de aplicabilidade ****'Gravar ficheiro ****If NApl = "£" Then ****sFileName = IntNum & "_" & NumYear & "_" & FName & "_SD" ****ThisWorkbook.SaveAs Filename:="L:\10_CBR_Common\Assuntos gerais\Gestão ECM\Aguarda Decisão" & "\" & sFileName ****' Enviar mail ****ActiveSheet.Range("A1:S7").Select ****'ActiveWorkbook.EnvelopeVisible = True ****ActiveWorkbook.EnvelopeVisible = False ****With ActiveSheet.MailEnvelope ********.Introduction = "Novo ECM com nº interno " & sFileName & " em " & "file://" & Replace(ActiveWorkbook.FullName, " ", "%20") & " para verificação." ********.Item.To = "email@domain.com" ********.Item.Subject = "Novo ECM para análise nº " & sFileName ********.Item.Send ********ActiveSheet.Range("A1").Select ****End With **** ********'ECM Com Decisão considerado aplicável ********'Gravar ficheiro ********ElseIf NApl = "R" Then ********sFileName = IntNum & "_" & NumYear & "_" & FName ********ThisWorkbook.SaveAs Filename:="L:\10_CBR_Common\Assuntos gerais\Gestão ECM\Aplicável" & "\" & sFileName ********'Enviar mail ********ActiveSheet.Range("A1:S7").Select ********ActiveWorkbook.EnvelopeVisible = False ********With ActiveSheet.MailEnvelope ************.Introduction = "ECM considerado APLICÁVEL com nº interno " & sFileName & " disponível em " & "file://" & Replace(ActiveWorkbook.FullName, " ", "%20") & " para dar seguimento." ************.Item.To = "email@domain.com" ************.Item.Subject = "ECM APLICÁVEL nº " & sFileName ************.Item.Send ************ActiveSheet.Range("A1").Select ********End With ******** ************'ECM Com Decisão considerado não aplicável ************'Gravar ficheiro ************ElseIf NApl = "Q" Then ************sFileName = IntNum & "_" & NumYear & "_" & FName & "_NA" ************ThisWorkbook.SaveAs Filename:="L:\10_CBR_Common\Assuntos gerais\Gestão ECM\Não Aplicável" & "\" & sFileName ************'Enviar mail ************ActiveSheet.Range("A1:S7").Select ************ActiveWorkbook.EnvelopeVisible = False ************With ActiveSheet.MailEnvelope ****************.Introduction = "ECM considerado NÃO APLICÁVEL. Arquivado com nº interno " & sFileName & " em " & "file://" & Replace(ActiveWorkbook.FullName, " ", "%20") ****************.Item.To = "email@domain.com" ****************.Item.Subject = "ECM NÃO APLICÁVEL nº " & sFileName ****************.Item.Send ****************ActiveSheet.Range("A1").Select ************End With **** ****End If **** ' Copy data to Index Dim range1 As Range, range2 As Range, range3 As Range, range4 As Range, range5 As Range, range6 As Range, range7 As Range, range8 As Range, multipleRange As Range Set range1 = Sheets("ECM").Range("N4") Set range2 = Sheets("ECM").Range("O4") Set range3 = Sheets("ECM").Range("D6") Set range4 = Sheets("ECM").Range("G6") Set range5 = Sheets("ECM").Range("K6") Set range6 = Sheets("ECM").Range("D7") Set range7 = Sheets("ECM").Range("K7") Set range8 = Sheets("ECM").Range("Q7") Set multipleRange = Union(range1, range2, range3, range4, range5, range6, range7, range8) Sheets("20160212_Acompanhamento ECM").Activate ****multipleRange.Select ****Range(Selection, Selection.End(xlDown)).Select ****Selection.Copy Sheets("Indice Interno ECM").rRange("A2").Select ****Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ ****:=False, Transpose:=False ActiveWindow.SelectedSheets.PrintOut Copies:=1 Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

My Issue is with the "Copy data to index". I'm trying to copy data from the start of the first file as per the 8 ranges specified above in the code. Please disregard the empty cells or columns. Some are merged:

Book1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

1

Ficha de Acompanhamento e Implementao de ECM

2

3

4

Nmero interno:

001

2016

Aplicvel?

£

5

6

N da ECM:

500000011599

Assunto:

Specification 784_0048

7

Responsvel:

Nuno Marques

Data:

2016.02.12

Prazo:

2016.02.12

ECM

Cell Formulas
Range	Formula
O4	=YEAR(TODAY())
G6	=IF(S4=UPPER("Q"),"NA","")

I want to copy those ranges to another workbook that I am using as an index:

Book1

A

B

C

D

E

F

G

H

1

N Interno

Ano

ECM

Aplicvel

Assunto

Responsvel

Data

Concluso

2

3

Index

The idea is that this way I can open the index, manually check the last used number in column A, go back to the ECM workbook, fill out the relevant data for the next ECM, press the button and save / send / copy and paste / print the file. The copy and paste would take the ranges and paste them to the next available blank row in the index.

The present code, however, does not work. I'm attaching the 2 files via dropbox in case it helps. I'd greatly appreciate it if anyone could help me as my Googling skills have reached their end I'm afraid.

The ECM: https://www.dropbox.com/s/4f6n5rxxw2qww5m/20160212_Acompanhamento%20ECM.xlsm?dl=0
The Index: https://www.dropbox.com/s/cpmgp1eudylbsi8/Indice%20Interno%20ECM.xlsx?dl=0

Hope someone can help!

Edit: ECM file link wasn't working. Fixed.

nmgmarques · Mar 9, 2016

I'm still at it, trying to get the copy to work. I have toyed around with a couple of things and it seems that the issue is that I am saving the file before I do the copy and that means of course a different file name, so the active sheet name was wrong all along. But even after I changed it I can't get it to work. So I ended up trying the following bits of code in hopes that I can define the current file name as a variable. I found 2 methods and tried both:

Code:

'Set CurrentName variable
    Dim wb      As Workbook
    Dim CurName     As String
    
    CurName = ThisWorkbook
    Set wb = Application.Workbooks("ThisWorkbook")
    
'Check if index is open. Referes to function CheckFileIsOpen
If CheckFileIsOpen("IndexECM.xlsx") = False Then
Workbooks.Open "L:\10_CBR_Common\Assuntos gerais\Gestão ECM\" & "IndexECM.xlsx"
End If
    
' Copy data to Index
Workbooks("CurName").Activate
Range("N4").Copy
Workbooks("IndexECM.xlsx").Activate
ActiveSheet.Range("A2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
'ActiveWindow.SelectedSheets.PrintOut Copies:=1

Thing is, CurName gives me an "Object doesn't support this property or method". If I comment CurName out and break after Set wb, in the Locals window I see Expression = wb, Value = Nothing and Type = Workbook. Am I wrong in thinking that the value should now be the current workbook filename? I still haven't gotten to the copying part since I can't get past this.

nmgmarques · Mar 9, 2016

And right after posting that, I found that my problem was I wasn't specifying what of the ThisWorkbook to define as the variable:

Code:

'Set CurrentName variable
    'Dim wb      As Workbook
    Dim CurName     As String
    
    CurName = ThisWorkbook.FullName
    'Set wb = Application.Workbooks("ThisWorkbook")

So not the variable is set as the full path + name of the file. All that's left now is to copy multiple cells from this current workbook over to the other already open workbook and paste there. If I step into the copy data to index portion, the first line is OK, but then the Worksheets ("ECM").Range("N4").Copy _ springs a Subscript out of range. I've had this error pop up all over the last couple of days, no matter what method of copy I try.

Ultimate goal is to copy multiple ranges (one at a time) and paste to the corresponding row in the IndexECM file. Please! Can anyone offer help?

Akuini · Mar 9, 2016

Hi, nmgmarques.
I downloaded your workbook sample. I modified your macro, and it works.
I don't use function CheckFileIsOpen, because it's not there.
The "20160212_Acompanhamento ECM.xlsm" must be the active sheet when you run the macro.

Code:

Sub try1()
    Dim wb      As Workbook
    Dim ws1 As Worksheet
        
    Set ws1 = ActiveSheet

'Check if index is open. Referes to function CheckFileIsOpen
'If CheckFileIsOpen("Indice Interno ECM.xlsx") = False Then
Workbooks.Open "D:\atry\ccc\Indice Interno ECM.xlsx"
'End If
' Copy data to Index
ActiveSheet.Range("A2").Value = ws1.Range("N4").Value

End Sub

nmgmarques · Mar 9, 2016

Akuini said:
Hi, nmgmarques.
I downloaded your workbook sample. I modified your macro, and it works.
I don't use function CheckFileIsOpen, because it's not there.
The "20160212_Acompanhamento ECM.xlsm" must be the active sheet when you run the macro.

Code:

Sub try1() Dim wb As Workbook Dim ws1 As Worksheet Set ws1 = ActiveSheet 'Check if index is open. Referes to function CheckFileIsOpen 'If CheckFileIsOpen("Indice Interno ECM.xlsx") = False Then Workbooks.Open "D:\atry\ccc\Indice Interno ECM.xlsx" 'End If ' Copy data to Index ActiveSheet.Range("A2").Value = ws1.Range("N4").Value End Sub

Hi Akuini. Thanks for your reply.

The file is a work in progress and I am trying to get where I want by going through the steps needed to get there. Just some 5 minutes ago I hit a breakthrough and managed to copy data to the index using:

Code:

' Copy data to IndexECM.xlsx
Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
Range("N4", "O4").Select
Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
'Range("B3").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste

Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
Range("N4").Select

So I realized I had to activate the correct workbooks and sheets like in your example. Just went at it a different way. Then the erow function lets me find the last empty row in the workbook and sheet (Index). Then I paste. This works, but the ActiveSheet.Paste method copies over the formats and also the merged cells, meaning that it copies N4 to A2 or whatever row the next empty cell is, but then it copies O4 (which is merged wit P4) and pastes it to B2 and C2.

So right now I am trying to figure out how to remove the empty cells from the paste and also how to paste without formats. I can get it to paste if I specify a Range() with a specific cell and then do a PasteSpecial, but I can't specify a specific cell to paste since I need to past on the next empty row for each ECM I create.

Does that make sense?

nmgmarques · Mar 9, 2016

I finally had it:

Code:

Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
Range("N4, O4, D6, G6, K6, D7, K7, Q7").Select
Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
'Range("B3").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
Range("N4").Select

Looked so promising when I tested with N4 and O4 in the range. But as soon as I expanded my range to the final intended range, it crapped out on me. It seems the problem stems from trying to extend the range onto different rows. Could this be?

Akuini · Mar 9, 2016

I modified your macro, try this:

Code:

Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
Range("N4, O4, D6, G6, K6, D7, K7, Q7").Select
Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
'Range("B3").Select
eRow = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).row
[COLOR=#0000cd]ActiveSheet.Cells(eRow, 1).Resize(8, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False[/COLOR]

Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
Range("N4").Select

nmgmarques · Mar 9, 2016

Akuini said:

I modified your macro, try this:

Code:

Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
Range("N4, O4, D6, G6, K6, D7, K7, Q7").Select
Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
'Range("B3").Select
eRow = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).row
[COLOR=#0000cd]ActiveSheet.Cells(eRow, 1).Resize(8, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False[/COLOR]

Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
Range("N4").Select

Didn't work. As soon as I extend the range to a second row, it errors out. And when I select only N4 and O4, I get 8 copies in Index

nmgmarques · Mar 9, 2016

Well, it's far from elegant, but it's working. So here is my final bit of code for the copy function. A repeating pattern of code. Best I could do. Pasting here in case anyone runs into similar difficulties in the future.

Code:

'Copy data to IndexECM.xlsx
'Activate Current ECM Workbook and copy range, then return to this workbook
Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
    Range("N4, O4").Select
        Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
    erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ActiveSheet.Cells(erow, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
    Range("D6").Select
        Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
    erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    ecol = ActiveSheet.Cells(erow, Columns.Count).End(xlToLeft).Column
    ActiveSheet.Cells(erow, "C").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
    Range("G6").Select
        Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
    erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    ecol = ActiveSheet.Cells(erow, Columns.Count).End(xlToLeft).Column
    ActiveSheet.Cells(erow, "D").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
    Range("K6").Select
        Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
    erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    ecol = ActiveSheet.Cells(erow, Columns.Count).End(xlToLeft).Column
    ActiveSheet.Cells(erow, "E").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
    Range("D7").Select
        Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
    erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    ecol = ActiveSheet.Cells(erow, Columns.Count).End(xlToLeft).Column
    ActiveSheet.Cells(erow, "F").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
    Range("K7").Select
        Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
    erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    ecol = ActiveSheet.Cells(erow, Columns.Count).End(xlToLeft).Column
    ActiveSheet.Cells(erow, "G").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
    Range("Q7").Select
        Selection.Copy

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
    erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    ecol = ActiveSheet.Cells(erow, Columns.Count).End(xlToLeft).Column
    ActiveSheet.Cells(erow, "H").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Workbooks("IndexECM.xlsx").Activate
Worksheets("Index").Activate
    erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    ActiveSheet.Cells(erow, "A").Select
        
Workbooks(ThisWorkbook.Name).Activate
Worksheets("ECM").Activate
    Range("N4").Select
    
ActiveWindow.SelectedSheets.PrintOut Copies:=1

Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub

Trouble copying with multipleRange

nmgmarques

Board Regular

Excel Facts

nmgmarques

Board Regular

nmgmarques

Board Regular

Akuini

Well-known Member

nmgmarques

Board Regular

nmgmarques

Board Regular

Akuini

Well-known Member

nmgmarques

Board Regular

nmgmarques

Board Regular

Similar threads

Forum statistics

Share this page

Trouble copying with multipleRange

Board Regular

Excel Facts

Board Regular

Board Regular

Well-known Member

Board Regular

Board Regular

Well-known Member

Board Regular

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock