1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

Solved: Excel 2007 VBA code to copy the first rows of a draft to various sheets

Discussion in 'Business Applications' started by madmaxxx89, Jun 30, 2011.

Thread Status:
Not open for further replies.
Advertisement
  1. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,591
    First Name:
    Hans
    Hi, I didn't change anything in your macro except changing the lines where the filenames where hardcoded to variables.

    If you check that part, your original line of code is preceded by an aposthrophe to disbale it, above that line is the code that activates the corresponding sheet, so if it's the other way around you will have to change that.

    I assumed that the starting sheet is the source workbook and the ones you select are the target.
    Except for the extra procedure where you select one or mnore files and the lines I mentioned, the code is unchanged so it it's not working correct mow it would have worked incorrectly with your code.

    The error with your Calcmode ...., I don't know I can't check anything because I have no valid data to do this.
    Below is a link and a sample of how to deactivate Calculation adn activate it again

    http://www.ozgrid.com/VBA/calc-stop.htm

    Code:
    Sub GoToManual()
    Dim xlCalc As XlCalculation
        xlCalc = Application.Calculation
        Application.Calculation = xlCalculationManual
        On Error GoTo CalcBack
    
    
        'YOUR CODE HERE' In your case that can be all the macro's so 
        call HauptAufruf
    
    
        Application.Calculation = xlCalc
        Exit Sub
    
    CalcBack:
    Application.Calculation = xlCalc
    End Sub
    
    If you can still not work it out I suggest you create two sample sheets with just a short numeber of yours, replace sentsitive data with blanks in the cells and post as attachment. You screen dumps do not tell me anything.

    Explaining something that is clear for you can in many ocasions not come accross as intended to the reader.
    Ín my case, I simply do not understand your screen dumps
     
  2. madmaxxx89

    madmaxxx89 Thread Starter

    Joined:
    Jun 29, 2011
    Messages:
    43
    Big success this morning!

    The Macro worked how I wanted it. Thank you very very much!

    I just exchanged the wsSource with the wsTarget in the code where it copies from one to another file.
    Code:
    Sub KopiereVonVorlageFormelnUndSpalten(wsSource As Worksheet, wsTarget As Worksheet)
    '
    ' KopiereVonVorlageFormelnUndSpalten Macro '
    '    wsSource.Activate
    '    Windows("0_AAA_Vorlage für Kundenlisten.xlsx").Activate
        wsTarget.Activate
        ActiveWindow.WindowState = xlNormal
        ActiveWindow.WindowState = xlNormal
        Rows("1:2").Select
        Range("A2").Activate
        Selection.Copy
     
        wsSource.Activate
    '    Windows("Wunderli Rainer Kundenliste 2010 TEST.xlsx").Activate
        Rows("1:2").Select
        Range("A2").Activate
        ActiveSheet.Paste
        wsTarget.Activate
    '    Windows("0_AAA_Vorlage für Kundenlisten.xlsx").Activate
        ActiveWindow.WindowState = xlNormal
        ActiveWindow.WindowState = xlNormal
        Range("B4:D4").Select
        Application.CutCopyMode = False
        Selection.Copy
    Just one more litte question. I realised that you edited the Sub AllesSeite1() to Sub AllesSeite1(wsSource As Worksheet, wsTarget As Worksheet). But now I cannot see the Macro anymore in the list (Screenshot). How could I change that? I want to use the "wsSource As Worksheet" in my code but I want be able to run it by clicking on Macros and then selecting it.
     

    Attached Files:

  3. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,591
    First Name:
    Hans
    A Macro that requires Parameters is not visible as a "simple" macro.

    I suggest you use the Sub HauptAufRuf I wrote but then you will have to change it so the source and target are correct.

    Code:
    Sub HauptAufruf()
    ' Here comes the part to define the workbooks and corresponding sheets you will need
    
    Dim wbSource As Workbook, wsSource As Worksheet
    Dim wbTarget As Workbook, wsTarget As Worksheet
    Dim Targetfilename As String
    Dim myArr(), Customarray(), x As Integer, xLoop As Boolean, isValid As Boolean
    
    Set wbSource = Workbooks(ActiveWorkbook.Name)
    Set wsSource = wbSource.Sheets(ActiveSheet.Name)
    
    Dim fPath, fName, msg As String
    fPath = GetParentFolder(ActiveWorkbook.Path)
    x = 0
    msg = vbNullString
    FileLoop:
        isValid = False
        Targetfilename = Application.GetOpenFilename("Excel files (*.xls?)," & "*.xl*", 1, "", "Open", False)
        isValid = FileExists(Targetfilename)
        If isValid = False And x = 0 Then
            GoTo EndMacro
        ElseIf isValid = False And x > 0 Then
            GoTo ExitLoop
        End If
        ' Check if file exists or if choice is valid
        If FileExists(Targetfilename) = True Then
            If Targetfilename <> ActiveWorkbook.FullName Then
                fPath = GetFilePath(Targetfilename)
                fName = GetFileName(Targetfilename)
                x = x + 1
                ReDim Preserve myArr(1 To x)
                myArr(x) = Targetfilename
                msg = msg & x & ". " & fName & vbCrLf
            End If
        Else
            MsgBox "Invalid choice!", vbCritical, ""
        End If
        If MsgBox(msg & vbCrLf & "Select another target file?", vbYesNo, "") = vbYes Then GoTo FileLoop
    ExitLoop:
    If x = 0 Then GoTo EndMacro
    ReDim Preserve Customarray(UBound(myArr()) - LBound(myArr()) + 1, 2)
    For x = LBound(myArr()) To UBound(myArr())
        Customarray(x, 1) = GetFilePath(CStr(myArr(x)))
        Customarray(x, 2) = GetFileName(CStr(myArr(x)))
    Next x
    For x = LBound(Customarray()) To UBound(Customarray())
        Targetfilename = Customarray(x, 1) & "\" & Customarray(x, 2)
        Set wbTarget = Application.Workbooks.Open(Targetfilename, ReadOnly:=False)
        Set wsTarget = wbTarget.Sheets(1)
        wbSource.Activate
        If MsgBox("Process : " & wbTarget.Name & "?", vbYesNo, "") = vbYes Then
    
            AllesSeite1 wsSource:=wsSource, wsTarget:=wsTarget
    
            MsgBox wbTarget.Name & " verarbeitet!", , ""
            On Error Resume Next
            wbTarget.Close SaveChanges:=True
            On Error GoTo 0
        End If
    Next x
    GoTo ExitMacro
    
    EndMacro:
    MsgBox "Incorrect or No targetfile selected!", vbExclamation, ""
    ExitMacro:
    End Sub
    
    You will have to edit the above code.
     
  4. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,591
    First Name:
    Hans
    Did you get it to work?
     
  5. madmaxxx89

    madmaxxx89 Thread Starter

    Joined:
    Jun 29, 2011
    Messages:
    43
    I tried... What I did:

    I added to the Sub AllesSeite1 a new Macro that should be called.

    Code:
     
    Sub AllesSeite1(wsSource As Worksheet, wsTarget As Worksheet)
        Call AllesEinheitlich
        Call Loop_Example
        Call ConvertToNumber
        Call SpaltenEinfügen
        Call KopiereVonVorlageFormelnUndSpalten(wsSource, wsTarget)
        Call autofill
        [COLOR=red]Call Sortieren(wsSource, wsTarget)[/COLOR]
    End Sub
    
    Because I also want to refer to the actual worksheet using wsSource and wsTarget I suggest I had to ad (wsSource, wsTarget).

    I recorded a Macro to sort the rows and it worked just fine for one file ith the Sheetname: ORG_SAL_KUNDENLISTE_P0012 1


    Now I tried to replace the reference to the sheet name with wsSource:
    I replaced: "ActiveWorkbook.Worksheets("ORG_SAL_KUNDENLISTE_P0012 1 ").Sort.SortFields." with
    " ActiveWorkbook.Worksheets(wsSource).Sort.SortFields."

    the new code looks like this:


    Everything I changed from the recorded Macro is marked red. Why isn't it working using wsSource? It worked just fine in this Macro:
     
  6. madmaxxx89

    madmaxxx89 Thread Starter

    Joined:
    Jun 29, 2011
    Messages:
    43
    I forgot to say: When I tried to run the HauptAufruf1 with the SOrtieren MAcro added I got a "Run-time error '13': Type mismatch on this line":
    ActiveWorkbook.Worksheets(wsSource).Sort.SortFields.Clear
     
  7. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,591
    First Name:
    Hans
    'There mus be a syntax errro there.

    I don't have a sample of the Sortieren Macro here,
    Have you passed the wsSource as a variable to the macro?

    Sub Sortieren(wsSorce as worksheet)
     
  8. madmaxxx89

    madmaxxx89 Thread Starter

    Joined:
    Jun 29, 2011
    Messages:
    43
    Yes I did that. It looks like this.


    Code:
     
    Sub Sortieren(wsSource As Worksheet, wsTarget As Worksheet)
    '
    ' Sortieren Macro
    '
    wsSource.Activate
    Rows("4:4").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ActiveWorkbook.Worksheets(wsSource).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(wsSource).Sort.SortFields.Add _
    Key:=Range("S4:S6327"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(wsSource).Sort.SortFields.Add _
    Key:=Range("P4:P6327"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(wsSource).Sort.SortFields.Add _
    Key:=Range("G4:G6327"), SortOn:=xlSortOnValues, Order:=xlDescending, _
    DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(wsSource).Sort.SortFields.Add _
    Key:=Range("E4:E6327"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(wsSource).Sort
    .SetRange Range("A4:X6327")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
    End Sub
    


    The recorded version worked good and looks like this:

    Code:
    Sub Sortieren()
    '
    ' Sortieren Macro
    '
        wsSource.Activate
        Rows("4:4").Select
        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        ActiveWorkbook.Worksheets("ORG_SAL_KUNDENLISTE_P0012 1 ").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("ORG_SAL_KUNDENLISTE_P0012 1 ").Sort.SortFields.Add _
            Key:=Range("S4:S6327"), SortOn:=xlSortOnValues, Order:=xlAscending, _
            DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets("ORG_SAL_KUNDENLISTE_P0012 1 ").Sort.SortFields.Add _
            Key:=Range("P4:P6327"), SortOn:=xlSortOnValues, Order:=xlAscending, _
            DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets("ORG_SAL_KUNDENLISTE_P0012 1 ").Sort.SortFields.Add _
            Key:=Range("G4:G6327"), SortOn:=xlSortOnValues, Order:=xlDescending, _
            DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets("ORG_SAL_KUNDENLISTE_P0012 1 ").Sort.SortFields.Add _
            Key:=Range("E4:E6327"), SortOn:=xlSortOnValues, Order:=xlAscending, _
            DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("ORG_SAL_KUNDENLISTE_P0012 1 ").Sort
            .SetRange Range("A4:X6327")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End Sub
     
  9. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,591
    First Name:
    Hans
    You must change wsSource to wsSource.Name

    Code:
    Sub Sortieren(wsSource As Worksheet, wsTarget As Worksheet)
    '
    ' Sortieren Macro
    '
    wsSource.Activate
    Rows("4:4").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ActiveWorkbook.Worksheets(wsSource.Name).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(wsSource.Name).Sort.SortFields.Add _
    Key:=Range("S4:S6327"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(wsSource.Name).Sort.SortFields.Add _
    Key:=Range("P4:P6327"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(wsSource.Name).Sort.SortFields.Add _
    Key:=Range("G4:G6327"), SortOn:=xlSortOnValues, Order:=xlDescending, _
    DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(wsSource.Name).Sort.SortFields.Add _
    Key:=Range("E4:E6327"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(wsSource.Name).Sort
    .SetRange Range("A4:X6327")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
    
     
  10. madmaxxx89

    madmaxxx89 Thread Starter

    Joined:
    Jun 29, 2011
    Messages:
    43
    It finally works perfect how I wanted. Thank sooooo much!
     
  11. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,591
    First Name:
    Hans
    Keine dank, bitte schönn.
    My pleasure
     
  12. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,591
    First Name:
    Hans
    Don't forget to mark the post as Solved.
    Use the button.

    :)
     
  13. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,591
    First Name:
    Hans
    The problem is that you are applying the function to a whole range and not a sigle cell.

    I change your code.

    Code:
    Dim Cell as Range
    
            For Each Cell In Range("C" & Firstrow & ":C" & Lastrow)
            'We check the values in the column in this example
                'With .Cells(Lrow, "C")
     
                 'If IsError(.Value) Then
                 ' GoTo Ende
     
     
               If WorksheetFunction.IsNA(Cell.Value) = True Then
                    GoTo Ende
                Else
                    Cell.Copy
                    Cell.Offset(0, 1).PasteSpecial
                End If
            
    Ende:
       Next Cell
    
    
    Try this and see if it works.
     
  14. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,591
    First Name:
    Hans
    You did NOT use my code

    Try again

    And I pasted it in the correct post again
     
  15. madmaxxx89

    madmaxxx89 Thread Starter

    Joined:
    Jun 29, 2011
    Messages:
    43
    I will mark this thread as solved. I'm impressed that you speak german.
     
As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/1004999

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice