I need help in writing a macro

Hiport

Active Member
Joined
May 9, 2008
Messages
455
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

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
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
 
Upvote 0
Hi Alexxander thanks for getting back, my answer to your question below.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p></o:p>
<o:p></o:p>
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:p></o:p>
<o:p></o:p>
2.The data should be on Row 2 when copied to a new workbook<o:p></o:p>
<o:p></o:p>
3. The data copied will be both text and values as per my example below.<o:p></o:p>
<o:p></o:p>
4. Naming convention c:\users\Jamie\caseref01 but once there is 50 sheets then the new workbook should save as caseref02 etc<o:p></o:p>
<o:p></o:p>
<o:p></o:p>
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:p></o:p>
<o:p></o:p>
Hope this is not too much work.<o:p></o:p>
<o:p></o:p>
CaseRef value date amount AGE SIDE REF<o:p></o:p>
<o:p></o:p>
AMP1 <?xml:namespace prefix = st1 ns = "urn:schemas-microsoft-com:eek:ffice:smarttags" /><st1:date Month="6" Day="15" Year="2008">15/06/08</st1:date> 369.36 12 SCR CBWTRN<o:p></o:p>
<o:p></o:p>


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
 
Upvote 0
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).
 
Upvote 0
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).
 
Upvote 0
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.
 
Upvote 0
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
    Set wb = Workbooks.Add
    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)
    Set ws = wb.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    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
 
Upvote 0
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
    Set wb = Workbooks.Add
    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)
    Set ws = wb.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    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
 
Upvote 0
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
    Set wb = Workbooks.Add
    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)
    Set ws = wb.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    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.
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,245
Members
448,555
Latest member
RobertJones1986

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Back
Top