I need help in writing a macro

[Hiport]

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

 

[xenou]

Oh yeah, of course...you have to create the index entry for all the references already existing.

NOTE: See my previous two posts if you haven't already - this is number three post in a row for me.

 

[Hiport]

First of all Alexander thankyou very much for the time you spent writing this code for me, much appreciated. I did test this out, and the only issue I had was that when i typed AMP1 and double click it, it created caseref01, but it didnt put the sheet name AMP1, but it did for AMP2 and so on, so when the workbook opened, the sheets at the bottom were, Sheet1 Sheet2 and Sheet3, AMP 2 Came after Sheet 3. I rather not have Sheet 2 and Sheet 3, would like to keep it consistent, like AMP1 AMP2 and so.

How do I get around this problem?

Oh yeah, of course...you have to create the index entry for all the references already existing.

NOTE: See my previous two posts if you haven't already - this is number three post in a row for me.

 

[xenou]

Right. There isn't a name being given to the sheets when a new book is started.

Here's the revision - just replace this code for the old code for this subroutine only.

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
    wb.Worksheets(1).Name = strCaseRef
    'Delete extra sheets
    For Each ws In wb.Worksheets
        If UCase(Left(ws.Name), 5) = "SHEET" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next ws
    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

 

[Hiport]

my i get a compile error "Argument not optional, by using your revised code, "Left" is highlighted when i get the error

If UCase(Left(ws.Name), 5) = "SHEET" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If

 

[Hiport]

Mate, when i get rid of U Case(Left ,5 and just leave ws.name=Sheet then i get AMP1 as a sheet name but it still leaves sheet2 and sheet 3 next to it.

Did you get the same problem your end?

my i get a compile error "Argument not optional, by using your revised code, "Left" is highlighted when i get the error

If UCase(Left(ws.Name), 5) = "SHEET" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If

 

[xenou]

Oops,
that line should be:

If UCase(Left(ws.Name, 5)) = "SHEET" Then

AB

 

[xenou]

Would it be possible to add some code to the orignal code in order to exapand the columns, at the moment when i case a new case entry, the caseref file opens but i have to widen the columns for dates and amounts

Also can we merge cells via code in order for me to write comments for each case ref. So i would like to merge 2 rows at a time, eg. B6:G7 with a black border, then B8:G9 with a blackborder and so on, i can send you a sample via email if you wish, so it would be easier to visualise.

First, to autofit columns you can add this Subroutine and Function to your standard module:

Sub MyAutoFitColumns(ByRef ws As Worksheet)
    Dim x As Long
    For x = GetLastColumn(ws) To 1 Step -1
    ws.Columns(x).AutoFit
    Next x
End Sub
'------------------------------------------------------
Function GetLastColumn(ByRef ws As Worksheet) As Long
'Returns number of last used column on a worksheet
    GetLastColumn = ws.Cells.Find("*", [A1], xlFormulas, xlPart, _
        xlByColumns, xlPrevious, False, False).Column
End Function

Then alter your code to call this sub when needed.
For instance in the routine DoubleClicked, just after these three lines:

    'Try to find the sheet for the case ref by its name
    On Error Resume Next
    wbOpened.Worksheets(strCaseRef).Activate

You add the subroutine call so your code looks like:

'Try to find the sheet for the case ref by its name
    On Error Resume Next
    wbOpened.Worksheets(strCaseRef).Activate
    Call MyAutoFitColumns(Worksheets(strCaseRef)) 'NEW LINE

And also in the routine SendCaseToWorkbook you add the subroutine call just after these lines:

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

So your code looks like:

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
    Call MyAutoFitColumns(Worksheets(strCaseRef)) 'NEW LINE

and of course the code continues with a few more lines...

----------------------------------------------

Second, to merge cells you can use code. I'm going to take this as being an independent set of routines. This code will work on the active cell, which is basically whatever cell you are currently working in. If for instance you want to merge B6:G7 you'd need to have the active cell as B6 when you run the code. I'd suggest you assign a shortcut key, so can for instance just hit Control + Shift + M from the keyboard and the code will run...

Merged cells are in general not very easy to work with in code, so if you want to code something to work with these merged cells, it will be no fun! In fact, as I think about this, it may cause trouble trying to autofit the columns we just worked out...

Another option would be to size the column b very wide, and just use "wrap text" - this works out much the same as a merged cell in appearance. With wrapping text, you probably want some extra column width (and/or taller rows).
MERGE OPTION:

Sub MergeCellsTwoRowsSixColumns()
    Dim rng As Range
    Set rng = ActiveCell.Resize(2, 6)
    rng.Merge
    Call MyBorders(rng)
End Sub
'---------------------------------
Sub MyBorders(ByRef rng As Range)
    With rng.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With rng.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With rng.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With rng.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
End Sub

Here would be the code to use wrap text and a larger cell instead.
WRAP OPTION:

Sub MyWrapTextAndExtendCellSize()
Dim rng As Range
Set rng = ActiveCell
    rng.WrapText = True
    rng.EntireColumn.ColumnWidth = 54.14
    rng.EntireRow.RowHeight = 25.5
    Call MyBorders(rng)
End Sub

--this uses same MyBorders subroutine as above. HTH!