# I need help in writing a macro

#### Hiport

##### Active Member
i was wondering if a macro can be written to copy data from a current spreadhseet to another workbook, basically i want to copy data from ranges A2 to A6 by clicking CELL A1 and from CELL B2 to B6 by clicking B2 and so on

File should be saved in this location

c:\users\jamie\ref

### Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

#### xenou

##### MrExcel MVP
Hi,
Do you want to save the data to a brand new workbook or to an existing workbook?

If its a new workbook, what type of naming convention do you want to use for the workbook? Also would the data be saved in the same location (for instance, in the second row), or put at the top (i.e., in cell A1 of the new workbook)? And, do you want to save values only or preserve formulas?

Regards,
AB

#### Hiport

##### Active Member
Hi Alexxander thanks for getting back, my answer to your question below.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
1. I want to save the data to a new workbook, but i want each new workbook to have 50 sheets with case numbers (AMP1 -AMP50) which i have assigned in my source sheet and then the macro should create a new workbook for another 50 etc.<o></o>
<o></o>
2.The data should be on Row 2 when copied to a new workbook<o></o>
<o></o>
3. The data copied will be both text and values as per my example below.<o></o>
<o></o>
4. Naming convention c:\users\Jamie\caseref01 but once there is 50 sheets then the new workbook should save as caseref02 etc<o></o>
<o></o>
<o></o>
my data will look something like the below which is what needs to be copied to a new workbook by clicking AMP1 etc and when I case another entry with AMP2 it should copy do the same thing as above. I hope this makes sense, at the same time any cases which have been saved already i should be able to open by just cliking on the cell, so for example if the below has been cased then by clicking AMP1, it should open up the releavnt case book up as per step 2 above, but if its a new case then it first needs to be saved before i can open it.<o></o>
<o></o>
Hope this is not too much work.<o></o>
<o></o>
CaseRef value date amount AGE SIDE REF<o></o>
<o></o>
AMP1 <?xml:namespace prefix = st1 ns = "urn:schemas-microsoft-comffice:smarttags" /><st1:date Month="6" Day="15" Year="2008">15/06/08</st1:date> 369.36 12 SCR CBWTRN<o></o>
<o></o>

Hi,
Do you want to save the data to a brand new workbook or to an existing workbook?

If its a new workbook, what type of naming convention do you want to use for the workbook? Also would the data be saved in the same location (for instance, in the second row), or put at the top (i.e., in cell A1 of the new workbook)? And, do you want to save values only or preserve formulas?

Regards,
AB

#### xenou

##### MrExcel MVP
Hope this is not too much work

Okay, a little challenging...

I think given your requirements the most difficult part will be to determine whether a case is in a workbook or not (for finding previous cases), and determining whether a new workbook needs to be created (i.e., whether the most recent workbook has 50 sheets or not).

There's probably a number of algorithms to work all this out but maybe easiest would be to have an index worksheet of data in your master workbook - i.e., a sheet listing case numbers and the names of the workbooks where those cases are stored. Would that be a problem? If not, the code would not only create the file but also add information to your index to help you track these files (the index could be hidden - no need to see it really).

#### Hiport

##### Active Member
Index worksheet would not be a problem.

Okay, a little challenging...

I think given your requirements the most difficult part will be to determine whether a case is in a workbook or not (for finding previous cases), and determining whether a new workbook needs to be created (i.e., whether the most recent workbook has 50 sheets or not).

There's probably a number of algorithms to work all this out but maybe easiest would be to have an index worksheet of data in your master workbook - i.e., a sheet listing case numbers and the names of the workbooks where those cases are stored. Would that be a problem? If not, the code would not only create the file but also add information to your index to help you track these files (the index could be hidden - no need to see it really).

#### Hiport

##### Active Member
Can anyone help me with the above? Its challenging thats for sure, i showed my IT dept and they said its too hard to do, so i was hoping someone from the board could help with this.

#### xenou

##### MrExcel MVP
I screwed it up...forgot about the workbooks part.

Here's what I have so far. Ran out of time. If anyone cares to tinker with this edit in any way desired.

Notes: when a range is entered into a variant, the array is always 1-based. When using the Array() method the array is 0-based (as here), unless otherwise set by the Option Base statement in the module declarations.

Worksheet level code - double-click event
Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngCase As Range
Dim strCase As String

If Target.Column = 1 Then 'Assumes case references are in column A
Cancel = True
Set rngCase = Target.Resize(1, 6)
strCase = Target.Value

Call DoubleClicked(rngCase, strCase)

End If

End Sub

Standard Module Code:
Code:
Option Explicit

Sub CallDoubleClicked()
'Test sub
Call DoubleClicked(Range(Cells(2, 1), Cells(2, 6)), "AMP17")
End Sub
Sub DoubleClicked(rngCase As Range, strCaseRef As String)
'DoubleClick Event to send the range to copy and the case reference to this sub
Dim strPath As String
Dim x As Long
Dim arrIndex() As Variant
Dim RefElements As Variant
Dim mainWb As Workbook
Dim blnFound As Boolean

'reference original workbook and get index into an array
Set mainWb = ActiveWorkbook
arrIndex = Worksheets("MyIndex").Cells(1, 1).CurrentRegion.Value

'Find out if case reference already exists (look in first dimension of array)
x = 1
Do While x < UBound(arrIndex, 1)
If strCaseRef = arrIndex(x, 1) Then
blnFound = True
Exit Do
End If
x = x + 1
Loop

'If case reference exists, then open the file (path is in second dimension of array)
If blnFound Then
Workbooks.Open (arrIndex(x, 2))
Else
'Get Array with highest existing CaseRef Number and whether a new workbook is needed
RefElements = CaseRefElements(arrIndex)

'Write to a new workbook or to an existing workbook as needed
Call SendCaseToWorkbook(RefElements, rngCase, strCaseRef)

'Create a new Index Record
Call WriteToIndex(mainWb, RefElements, strCaseRef)

End If

End Sub
'-----------------------------------------------------------------
Private Function CaseRefElements(arrIndex) As Variant
Dim intMax As Integer
Dim intHighestCase As Integer
Dim blnNewWorkbook As Boolean
Dim i As Long

'LOGIC ERROR - DOESN'T GET FOR ME THE WORKBOOK NAME - written as if
'The case ref was the workbook name.  Needs another entry in the index

intHighestCase = 1 'Case Number within Workbooks
For i = 1 To UBound(arrIndex, 1)
If arrIndex(i, 3) > intHighestCase Then
intHighestCase = arrIndex(i, 3)
End If
Next i

If intHighestCase Mod 50 = 0 Then 'Multiple of 50
intMax = intMax + 1 'Start a new workbook
blnNewWorkbook = True

End If

CaseRefElements = Array(intHighestCase, blnNewWorkbook)

End Function
'-----------------------------------------------------------------
Private Sub SendCaseToWorkbook(Arg1 As Variant, myRange As Range, strCase As String)
Dim a As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim strTemp As String
Dim msg As String
Dim ans As String

a = myRange.Value

If Arg1(1) Then 'Start a new workbook
wb.Worksheets(1).Cells(2, 1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
strTemp = "C:\TEMP\jamie\ref\caseref" & Arg1(0) + 1 & ".xls"
wb.SaveAs strTemp
msg = "Save and close workbook now?"
ans = MsgBox(msg, vbYesNo)
If ans = vbYes Then wb.Close SaveChanges:=True

Else 'Open an existing workbook and add a sheet
strTemp = "C:\TEMP\jamie\ref\caseref" & Arg1(0) & ".xls"
Set wb = Workbooks.Open(strTemp)
ws.Name = strCase
ws.Cells(2, 1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
msg = "Save and close workbook now?"
ans = MsgBox(msg, vbYesNo)
If ans = vbYes Then wb.Close SaveChanges:=True

End If

End Sub
'-----------------------------------------------------------------
Private Sub WriteToIndex(wb As Workbook, RefElements, strCaseRef)
Dim ws As Worksheet
Dim LRow As Long
Dim strTemp As String

'LOGIC ERROR - index has Case Ref, Full Path, and Case Ref Integer portion
'Needs a column for the workbook Integer portion.

Set ws = wb.Worksheets("MyIndex")
LRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

ws.Cells(LRow + 1, 1).Value = RefElements(0) 'CaseRef
strTemp = "C:\TEMP\jamie\ref\caseref" & RefElements(1) + 1 & ".xls" 'FullPath
ws.Cells(LRow + 1, 2).Value = strTemp 'FullPath
ws.Cells(LRow + 1, 4).Value = strCaseRef 'CaseRef Number

End Sub

#### Hiport

##### Active Member
thanx for that mate, so when you mentioned you did not complete the workbooks part, do you mean that the double click even code will not open a workbook specified in the master workbook?

I screwed it up...forgot about the workbooks part.

Here's what I have so far. Ran out of time. If anyone cares to tinker with this edit in any way desired.

Notes: when a range is entered into a variant, the array is always 1-based. When using the Array() method the array is 0-based (as here), unless otherwise set by the Option Base statement in the module declarations.

Worksheet level code - double-click event
Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngCase As Range
Dim strCase As String

If Target.Column = 1 Then 'Assumes case references are in column A
Cancel = True
Set rngCase = Target.Resize(1, 6)
strCase = Target.Value

Call DoubleClicked(rngCase, strCase)

End If

End Sub

Standard Module Code:
Code:
Option Explicit

Sub CallDoubleClicked()
'Test sub
Call DoubleClicked(Range(Cells(2, 1), Cells(2, 6)), "AMP17")
End Sub
Sub DoubleClicked(rngCase As Range, strCaseRef As String)
'DoubleClick Event to send the range to copy and the case reference to this sub
Dim strPath As String
Dim x As Long
Dim arrIndex() As Variant
Dim RefElements As Variant
Dim mainWb As Workbook
Dim blnFound As Boolean

'reference original workbook and get index into an array
Set mainWb = ActiveWorkbook
arrIndex = Worksheets("MyIndex").Cells(1, 1).CurrentRegion.Value

'Find out if case reference already exists (look in first dimension of array)
x = 1
Do While x < UBound(arrIndex, 1)
If strCaseRef = arrIndex(x, 1) Then
blnFound = True
Exit Do
End If
x = x + 1
Loop

'If case reference exists, then open the file (path is in second dimension of array)
If blnFound Then
Workbooks.Open (arrIndex(x, 2))
Else
'Get Array with highest existing CaseRef Number and whether a new workbook is needed
RefElements = CaseRefElements(arrIndex)

'Write to a new workbook or to an existing workbook as needed
Call SendCaseToWorkbook(RefElements, rngCase, strCaseRef)

'Create a new Index Record
Call WriteToIndex(mainWb, RefElements, strCaseRef)

End If

End Sub
'-----------------------------------------------------------------
Private Function CaseRefElements(arrIndex) As Variant
Dim intMax As Integer
Dim intHighestCase As Integer
Dim blnNewWorkbook As Boolean
Dim i As Long

'LOGIC ERROR - DOESN'T GET FOR ME THE WORKBOOK NAME - written as if
'The case ref was the workbook name.  Needs another entry in the index

intHighestCase = 1 'Case Number within Workbooks
For i = 1 To UBound(arrIndex, 1)
If arrIndex(i, 3) > intHighestCase Then
intHighestCase = arrIndex(i, 3)
End If
Next i

If intHighestCase Mod 50 = 0 Then 'Multiple of 50
intMax = intMax + 1 'Start a new workbook
blnNewWorkbook = True

End If

CaseRefElements = Array(intHighestCase, blnNewWorkbook)

End Function
'-----------------------------------------------------------------
Private Sub SendCaseToWorkbook(Arg1 As Variant, myRange As Range, strCase As String)
Dim a As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim strTemp As String
Dim msg As String
Dim ans As String

a = myRange.Value

If Arg1(1) Then 'Start a new workbook
wb.Worksheets(1).Cells(2, 1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
strTemp = "C:\TEMP\jamie\ref\caseref" & Arg1(0) + 1 & ".xls"
wb.SaveAs strTemp
msg = "Save and close workbook now?"
ans = MsgBox(msg, vbYesNo)
If ans = vbYes Then wb.Close SaveChanges:=True

Else 'Open an existing workbook and add a sheet
strTemp = "C:\TEMP\jamie\ref\caseref" & Arg1(0) & ".xls"
Set wb = Workbooks.Open(strTemp)
ws.Name = strCase
ws.Cells(2, 1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
msg = "Save and close workbook now?"
ans = MsgBox(msg, vbYesNo)
If ans = vbYes Then wb.Close SaveChanges:=True

End If

End Sub
'-----------------------------------------------------------------
Private Sub WriteToIndex(wb As Workbook, RefElements, strCaseRef)
Dim ws As Worksheet
Dim LRow As Long
Dim strTemp As String

'LOGIC ERROR - index has Case Ref, Full Path, and Case Ref Integer portion
'Needs a column for the workbook Integer portion.

Set ws = wb.Worksheets("MyIndex")
LRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

ws.Cells(LRow + 1, 1).Value = RefElements(0) 'CaseRef
strTemp = "C:\TEMP\jamie\ref\caseref" & RefElements(1) + 1 & ".xls" 'FullPath
ws.Cells(LRow + 1, 2).Value = strTemp 'FullPath
ws.Cells(LRow + 1, 4).Value = strCaseRef 'CaseRef Number

End Sub

#### xenou

##### MrExcel MVP
Okay, this isn't fully tested - I made three step throughs to check three cases - existing ref, new ref in existing workbook, and new ref in new workbook). I ditched much of my not-so-sophisticated array handling (sigh). There may be bugs if something unexpected happens (input data that isn't right to begin with) - so if you have other users besides yourself it's probably not sufficiently controlled for non-standard input.

Worksheet level code - double-click event
Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngCase As Range
Dim strCase As String

If Target.Column = 1 Then 'Assumes case references are in column A
Cancel = True
Set rngCase = Target.Resize(1, 6)
strCase = Target.Value

Call DoubleClicked(rngCase, strCase)

End If

End Sub

Standard Module Code:
Code:
Option Explicit
Private wbMain As Workbook
Private wsMain As Worksheet
Private wsIndex As Worksheet
'-------------------------------------------------------
Sub DoubleClicked(rngCase As Range, strCaseRef As String)
'DoubleClick Event to send the range to copy and the case reference to this sub
Dim strPath As String
Dim x As Long
Dim arrIndex() As Variant
Dim RefElements As Variant
Dim blnFound As Boolean
Dim intLRowIndex As Long
Dim intLastCaseRef As Integer
Dim wbOpened As Workbook

'references
Set wbMain = ActiveWorkbook
Set wsMain = ActiveSheet
Set wsIndex = Worksheets("MyIndex")
intLRowIndex = wsIndex.Cells(Rows.Count, 1).End(xlUp).Row
intLastCaseRef = wsIndex.Cells(intLRowIndex, 3).Value

'Find out if case reference already exists (look in first column of index)
For x = intLRowIndex To 1 Step -1
If strCaseRef = wsIndex.Cells(x, 1).Value Then
blnFound = True
Exit For
End If
Next x

'If case reference exists, then open the file (path is in second column of index)
If blnFound Then
Set wbOpened = Workbooks.Open(wsIndex.Cells(x, 2).Value)
On Error Resume Next
wbOpened.Worksheets(strCaseRef).Activate
On Error GoTo 0
Else
'Get Array value
'Function returns:
'     1. Highest current CaseRef Number
'     2. Whether a new workbook is needed
'     3. If so, next incremental number for file name
RefElements = GetCaseRefElements()

'Write to a new workbook or to an existing workbook as needed
'SendCaseToWorkbook routine needs:
'     1. The RefElements data above
'     2. The rngToCopy from (in the row which was doubleclicked)
'     3. The Case Reference Number (in the cell which was doubleclicked)
Call SendCaseToWorkbook(RefElements, rngCase, strCaseRef)

'Create a new Index Record
Call WriteToIndex(RefElements, strCaseRef, intLRowIndex)

End If

End Sub
'-------------------------------------------------------
Private Function GetCaseRefElements() As Variant
Dim strWorkbookNumber As String
Dim intHighestCase As Integer
Dim blnNewWorkbook As Boolean

intHighestCase = WorksheetFunction.Max(wsIndex.Columns(3))

If intHighestCase Mod 50 = 0 Then 'Multiple of 50
strWorkbookNumber = CStr((intHighestCase / 50) + 1) 'Start a new workbook
Select Case Len(strWorkbookNumber)
Case Is < 10
strWorkbookNumber = "0" & strWorkbookNumber
Case Is > 99
MsgBox "This routine has reached its maximum of 99 workbooks."
End
End Select
blnNewWorkbook = True
Else
strWorkbookNumber = Int(intHighestCase / 50) + 1
If Len(strWorkbookNumber) < 10 Then strWorkbookNumber = "0" & strWorkbookNumber
End If

GetCaseRefElements = Array(intHighestCase, blnNewWorkbook, strWorkbookNumber)

End Function
'-------------------------------------------------------
Private Sub SendCaseToWorkbook(Arg1 As Variant, myRange As Range, strCaseRef As String)
Dim a As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim strTemp As String
Dim msg As String
Dim ans As String

a = myRange.Value

If Arg1(1) Then 'Start a new workbook
wb.Worksheets(1).Cells(2, 1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
strTemp = "C:\TEMP\jamie\ref\caseref" & Arg1(2) & ".xls"
wb.SaveAs strTemp
msg = "Save and close workbook now?"
ans = MsgBox(msg, vbYesNo)
If ans = vbYes Then wb.Close SaveChanges:=True

Else 'Open an existing workbook and add a sheet
strTemp = "C:\TEMP\jamie\ref\caseref" & Arg1(2) & ".xls"
Set wb = Workbooks.Open(strTemp)
ws.Name = strCaseRef
ws.Cells(2, 1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
msg = "Save and close workbook now?"
ans = MsgBox(msg, vbYesNo)
If ans = vbYes Then wb.Close SaveChanges:=True

End If

End Sub
'-------------------------------------------------------
Private Sub WriteToIndex(RefElements As Variant, strCaseRef As String, lRowIndex As Long)
Dim LRow As Long
Dim strTemp As String

'Writes an entry to next empty row in a worksheet called "MyIndex".
'That worksheet should be hidden to protect it from tampering.

wsIndex.Cells(lRowIndex + 1, 1).Value = strCaseRef 'CaseRef identifier
strTemp = "C:\TEMP\jamie\ref\caseref" & RefElements(2) & ".xls" 'FullPath
wsIndex.Cells(lRowIndex + 1, 2).Value = strTemp 'FullPath
wsIndex.Cells(lRowIndex + 1, 3).Value = RefElements(0) + 1 'CaseRef Numeric index
wbMain.Save

End Sub

I used one error-handler - if the worksheet is not found in the workbook when you double click an existing case ref, then probably just whatever worksheet is active will display on screen. To help maintain the integrity of the index on the MyIndex sheet, the routine will save the workbook as soon as a new entry is added to the index.

Let me know how this works for you.

#### xenou

##### MrExcel MVP
Here BTW is my index. It starts in row 1, column A, with no headers. I've shown the rows where we switch to a new workbook:

50 case refs would be in
C:\TEMP\jamie\ref\caseref01.xls

the 51st starts in
C:\TEMP\jamie\ref\caseref02.xls

------------------------------
IMPORTANT:
This reminds me that I've used a different folder for testing. Wherever I have C:\TEMP, I think you need C:\users.

Make that change in the code too, wherever I have the filepath construction!!!!
------------------------------
20080615_CaseRefs.xls
ABCD
47AMP47C:\TEMP\jamie\ref\caseref01.xls47
48AMP48C:\TEMP\jamie\ref\caseref01.xls48
49AMP49C:\TEMP\jamie\ref\caseref01.xls49
50AMP50C:\TEMP\jamie\ref\caseref01.xls50
51AMP51C:\TEMP\jamie\ref\caseref02.xls51
52AMP52C:\TEMP\jamie\ref\caseref02.xls52
53AMP53C:\TEMP\jamie\ref\caseref02.xls53
54AMP54C:\TEMP\jamie\ref\caseref02.xls54
MyIndex

Replies
0
Views
305
Replies
1
Views
801
Replies
13
Views
485
Replies
5
Views
502
Replies
10
Views
2K

1,190,639
Messages
5,982,079
Members
439,753
Latest member
mnyankee

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back