macro voor aantal functies

[arjoderoon]

ik zit nog met het probleem van de error melding over "xlpaste columnswidths"

de error die ik krijg:

compileerfout:

een variabele is niet gedefinieerd

in foutopsporing geeft Vb aan dat het probleem zit bij:

          sh.Range("A1").PasteSpecial xlPasteColumnWidths

een google zoektocht leert mij dat er in office 2000 iets anders gebruikt zou moeten worden voor de paste special?

http://www.pcreview.co.uk/forums/thread-952462.php

 

[arjoderoon]

hoe kan ik onderstaande nog meenemen in de macro voor de aanmaak van de database?
Het gaat mij erom dat de cellen in het bereik a1 : AC 208 gekopieerd worden.
Onderstaande is de macro code zoals de recorder deze gemaakt heeft.

 Workbooks.Open Filename:="sap.xls"
    Cells.Select
    Selection.Copy
    ThisWorkbook.Activate
    Sheets("Data SAP").Activate
    '*** Select the destination cell
    Range("A1").Select
    ActiveSheet.Paste
    ActiveWorkbook.Save
    Application.CutCopyMode = False
    Workbooks("sap.xls").Close

als ik dit erin kopieer gebeurt er wel wat, maar loopt excel helemaal vast.

 

[cow18]

2 nieuwe codes
die macor allesin1keer gaat je SAP-file inlezen en direkt omslaan naar die 2e table en daarna de draaitabel vernieuwen

Sub AllesIn1Keer()
  OphalenSAP
  AanmaakDatabase
  Sheets("draaitabel").PivotTables(1).RefreshTable
End Sub

Sub OphalenSAP()
  Sheets("DATA SAP").Cells.Clear
  Sheets("Database").UsedRange.Offset(1).ClearContents
  Workbooks.Open Filename:="sap.xls"
  Sheets(1).UsedRange.Copy ThisWorkbook.Sheets("Data SAP").Range("A1")
  Application.CutCopyMode = False
  Workbooks("sap.xls").Close xlNo
End Sub

aanpassingen in ht rood ivm je kolombreedten

Sub AanmaakDatabase()
  Dim c As Range, s As String, splits As Variant
  With Sheets("Data Sap")
    For Each c In .UsedRange.Columns("D:IV").Offset(1).SpecialCells(xlConstants)
      s = s & c.Offset(, 1 - c.Column).Value & vbTab & c.Offset(, 2 - c.Column).Value & vbTab & c.Offset(, 3 - c.Column).Value & vbTab & c.Offset(1 - c.Row).Value & vbTab & c.Value & vbLf
    Next
  End With

  With Sheets("database")
    .UsedRange.Offset(1).ClearContents
    splits = Split(s, vbLf)
    With .Range("A2").Resize(UBound(splits))
      .Value = WorksheetFunction.Transpose(splits)
      Application.DisplayAlerts = False
      .TextToColumns Tab:=True
      Application.DisplayAlerts = True
    End With
  End With
End Sub

Sub ElkeKlant()
  Dim PT As PivotTable, it As PivotItem, s As String, bereik As Range, sh As Worksheet, DBR As Range, c As Range, shDr As Worksheet
  Dim c1 As Range, ac As Range, i As Integer
  Application.ScreenUpdating = False
  Set ac = ActiveCell                                      'huidige cel
  Set shDr = Sheets("draaitabel")                          'werkblad "draaitabel
  Sheets("MijnTabel").UsedRange.Columns("A:G").Offset(1).ClearContents
  Set PT = Sheets("draaitabel").PivotTables(1)             'onze draaitabel zelf
  On Error Resume Next                                     'doorgaan bij fouten
  With PT.PivotFields("klant")                             'kijk naar het veld "klant
    .EnableMultiplePageItems = False                       'niet meervoudige selecteren
    For Each it In .PivotItems                             'loop elke klant af
      shDr.AutoFilterMode = False                          'ev. filter uitzetten
      s = it.Value                                         'een klant
      i = 0: i = WorksheetFunction.Match(s, Sheets("MijnTabel").Range("M2:M20"), 0)  'zoek in die klant in je lijst
      If i <> 0 Then
        .CurrentPage = s                                   'filter draaitabel op die klant
        Set sh = Nothing                                   'reset werkblad
        Set sh = Sheets(s)                                 'roep werkblad van de klant aan
        If sh Is Nothing Then                              'werkblad bestaat niet
          Sheets.Add after:=Sheets(Sheets.Count)           'nieuw werkblad achterin toevoegen
          ActiveSheet.Name = s                             'noem het naar de klant
        End If
        Set sh = Sheets(s)
        If sh.Name = Sheets("draaitabel").Name Then MsgBox "foutje": Exit Sub  'mag zeker nooit draaitabel noemen
        sh.Columns("A:G").Clear                            'kolommen A:G van klant wissen
        Set DBR = PT.DataBodyRange                         'bereik van databody van de draaitabel
        Set c = DBR.Range("A1").Offset(DBR.Rows.Count - 1, DBR.Columns.Count + 1)  'rechteronderhoek van te kopieren gegevens
        With Sheets("draaitabel")
          .Range("G4:G100").AutoFilter 1, "1"              'filter op artikelcode op de artikels "1" (80% van de omzet)
          .Range("A1:" & c.Address).Copy                   'kopieer bereik
          sh.Range("A1").PasteSpecial xlAll                'plakken in klant
          sh.Range("A1").PasteSpecial xlValues
         [COLOR="red"] sh.Rows(1).EntireColumn.AutoFit[/COLOR]
          i = .Range("A5:" & c.Address).SpecialCells(xlVisible).Rows.Count
          .Range("A5:" & c.Address).SpecialCells(xlVisible).Copy  'kopieer bereik
          Set c1 = Sheets("mijnTabel").Range("A" & Rows.Count).End(xlUp).Offset(1)
          c1.Resize(i).Value = s
          With c1.Offset(, 1)
            .PasteSpecial xlAll                            'plakken in klant
            .Range("A1").PasteSpecial xlValues
          [COLOR="red"]  '.Range("A1").PasteSpecial xlPasteColumnWidths[/COLOR]
          End With
        End With
        Application.CutCopyMode = False
        Application.Goto sh.Range("A1"), False
      End If
    Next
    .CurrentPage = "(All)"                                 'gegevens voor alle klanten tonen
  End With
  Application.Goto ac, False
  shDr.AutoFilterMode = False
  Application.ScreenUpdating = True
End Sub