macro gebruiken voor hele sheet

Status
Niet open voor verdere reacties.
S

ssteenvoorde

Gebruiker
Lid geworden
4 mei 2018
Berichten
11
Hallo, deze macro heb ik opgenomen en wil ik graag gebruiken voor mijn hele excelsheet tm regel 1500.

Sub voorkeurhousing()
'
' voorkeurhousing Macro
' rapportage housing request
'
' Keyboard Shortcut: Ctrl+Shift+V
'
Range("A1:Q1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("A2").Select
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.SmallScroll ToRight:=8
Range("Q2").Select
Application.CutCopyMode = False
Selection.Cut
Range("R2").Select
ActiveSheet.Paste
Range("Q3").Select
Selection.Cut
Range("S2").Select
ActiveSheet.Paste
Range("Q4").Select
Selection.Cut
Range("T2").Select
ActiveSheet.Paste
Range("Q5").Select
Selection.Cut
Range("U2").Select
ActiveSheet.Paste
Range("Q6").Select
Selection.Cut
Range("V2").Select
ActiveSheet.Paste
Range("Q7").Select
Selection.Cut
Range("W2").Select
ActiveSheet.Paste
Range("Q8").Select
Selection.Cut
Range("X2").Select
ActiveSheet.Paste
Range("Q9").Select
Selection.Cut
Range("Y2").Select
ActiveSheet.Paste
Range("P2").Select
Selection.Copy
Range("R1").Select
ActiveSheet.Paste
Range("P3").Select
Application.CutCopyMode = False
Selection.Copy
Range("S1").Select
ActiveSheet.Paste
Range("P4").Select
Application.CutCopyMode = False
Selection.Copy
Range("T1").Select
ActiveSheet.Paste
Range("P5").Select
Application.CutCopyMode = False
Selection.Copy
Range("U1").Select
ActiveSheet.Paste
Range("P6").Select
Application.CutCopyMode = False
Selection.Copy
Range("V1").Select
ActiveSheet.Paste
Range("P7").Select
Application.CutCopyMode = False
Selection.Copy
Range("W1").Select
ActiveSheet.Paste
Range("P8").Select
Application.CutCopyMode = False
Selection.Copy
Range("X1").Select
ActiveSheet.Paste
Range("P9").Select
Application.CutCopyMode = False
Selection.Copy
Range("Y1").Select
ActiveSheet.Paste
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Rows("3:9").Select
Range("A9").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub


Kan iemand mij hiermee helpen aub?
Alvast bedankt!

Groet, Shin-Lee
 
Leg eens uit wat je prcies wilt. ook is het plaatsen van een voorbeeld bestand aangeraden
 
Beste,
Welkom op het forum:)
Een paar opmerkingen
Plaats je code tussen code tags, dit doe je door op het # symbool te klikken.;)
Post een gelijkend voorbeeld bestand waaruit duidelijk blijkt wat je wenst te bereiken (dus zonder gevoelige gegevens maar wat dummy gegevens)
Nu kan ik al zeggen.
Alle scrolls zijn overbodig, gewoon wissen.
deze lijnen dus
Code: 
ActiveWindow.ScrollColumn = ...
Application.CutCopyMode = False hoeft maar één keer, op het einde van je macro.
Alle selects zijn overbodig.
Dit
Code: 
Range("V1").Paste
doet hetzelfde als, alleen sneller
Code: 
Range("V1").Select
ActiveSheet.Paste
Om een voorbeeld bij te voegen klik rechts onder op Ga geavanceerd en klik op de paperclip.
 
ow sorry, ik ben inderdaad een beetje onduidelijk.
Ik heb een rapportage waarbij ik elke keer 8 rijen naar 8 kolommen wil verplaatsen. De overige 7 rijen wil ik dan verwijderen, zodat er maar 1 rij per 8 rijen overblijft met de juiste gegevens in de kolommen.
Dit moet dan zo"n 1500x gebeuren op een excelsheet.

zo staan de gegevens in excel in een rapportage

Voorkeur stad? test
Voorkeur prijscategorie Leiden? test
Voorkeur prijscategorie The Hague test
Toelichting test
Voorkeur stad 2?
Voorkeur prijs categorie Leiden 2
Voorkeur prijs categorie The Hague 2
Toelichting 2

Zo moet het er dan uit komen te zien (in excel natuurlijk)

Voorkeur stad? Voorkeur prijscategorie Leiden? Voorkeur prijscategorie The Hague Toelichting Voorkeur stad 2? Voorkeur prijs categorie Leiden 2 Voorkeur prijs categorie The Hague 2 Toelichting 2
Voorkeur stad? test test test test test test test test


er staan nog meer gegevens in de regels voordat bovenstaande tekst komt, maar die heb ik niet mee gekopieerd.
 
@SjonR, ik zie nog altijd geen voorbeeld bestand, Jij?
 
Nee, en de toelichting schept ook geen duidelijkheid :confused:
 
@SjonR,
Ok
Ik wacht op wat meer duidelijkheid van TS.
 
Een voorzetje

Code: 
Sub VenA()
  ar = Sheets("sheet1").Columns(17).SpecialCells(2)
  For j = 1 To UBound(ar)
    c00 = c00 & "|" & ar(j, 1) & IIf(j Mod 8 = 0, vbLf, "")
  Next j
  ar1 = Split(Mid(c00, 2), vbLf)
  Sheets.Add(, Sheets(Sheets.Count)).Cells(1).Resize(UBound(ar1)) = Application.Transpose(ar1)
End Sub
 
owwww...ik ben nog steeds onduidelijk?? ik probeerde het bestand te uploaden zodat jullie een voorbeeld konden zien, maar dit kan volgens mij niet toch?
Ik krijg op mijn Eigen pc hele onduidelijke printscreen, omdat ik een dubbel scherm heb. Ik zal vanaf een andere pc printscreens proberen te maken.
Sorry voor de onduidelijkheid:confused:
 

Bijlagen

  • Copy of SEA - Matchingfile (platte lijst).xlsm
    19,2 KB · Weergaven: 42
ow haha..ik zie dat het uploaden van het bestand nu wel gelukt is.
Op het eerste tabblad ''rapportage...'' staat de uitvoer zoals ik ze aangeleverd krijg.
Na het maken van de macro komen de gegevens zoals op sheet 1 te staan.
Alleen nu ben ik dus op zoek naar de code voor een bestand van 1500 regels die op dezelfde manier verwerkt moeten worden ipv alleen deze 8 regels...

Alvast bedankt!
 
Plaats een representatief voorbeeld. Staan er in het bestand dat je aangeleverd krijgt geen kolomkoppen? Waarom zijn een aantal kolommen leeg? Gaat het steeds om blokken van 8 regels? Zo ja dan kan 1500 niet juist zijn. Wat maakt zo'n blok van 8? regels uniek. Het maken zal niet zo ingewikkeld zijn maar is toch een stukje maatwerk en dan kan je de helpers beter voorzien van volledige informatie.

Nb. Zet de code in de OP even tussen codetags. (zie het linkje in #9)
 
Zet in elk kolom van je eerste blad kopteksten zodat je een aaneengesloten bereik verkrijgt.

Het zou dan zoiets worden.
Code: 
Sub hsv()
Dim sv, i As Long
sv = Sheets("rapportage voorkeur housing req").Cells(1).CurrentRegion
For i = 2 To UBound(sv) Step 8
 With Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp)
  .Offset(1).Resize(, 14) = Application.Index(sv, i, 0)
  .Offset(1, 17).Resize(, 8) = Application.Transpose(Application.Index(sv, Evaluate("row(" & i & ":" & i + 8 & ")"), 17))
 End With
Next i
End Sub
 
Allemaal bedankt voor jullie reacties. Macro's en dit forum zijn nieuw voor mij en zoals jullie kunnen zien ben Ik hier nog niet echt goed in.

Ik heb mijn macro opnieuw opgenomen, waardoor het misschien makkelijker te begrijpen is wat ik wil.
In de bijlage heb ik een voorbeeld van een rapportage waarbij ik een macro wil gebruiken. De bedoeling is om de gegevens bestaande uit 8 rijen te transporteren naar 8 kolommen. Dit betreffen gegevens van 1 persoon (de 8 regels). In mijn huidige macro heb ik de gegevens dus getransporteerd voor 4 personen. Waar ik naar op zoek ben is een macro voor een bestand van 1500 personen (x8 regels pp dus).
Kan iemand mij hiermee helpen aub?

De huidige macro:

Code: 
Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
    Range("P2:P9").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("R1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("Q2:Q9").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("R2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("Q10:Q17").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("R10").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("Q18:Q25").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("R18").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("Q26:Q33").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("R26").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub


Bekijk bijlage testfile rapportage FO.xlsm
 
Heb je het advies en de code van HSV in #13 wel geprobeerd? Zo ja wat werkt er dan niet? De vragen in #12 heb je ook nog niet beantwoord.
 
ssteenvoorde zei:
Ik krijg op mijn Eigen pc hele onduidelijke printscreen, omdat ik een dubbel scherm heb. Ik zal vanaf een andere pc printscreens proberen te maken. Sorry voor de onduidelijkheid:confused:
Klik om te vergroten...
Hmmm ....
Als ik dit probleem aan meneer Google vraag omdat ik het niet weet krijg ik meteen het juiste antwoord....
Weg onduidelijkheid... en das een stuk makkelijker dan een macro maken...
Wat houd je tegen om dat niet te proberen?
Google: https://www.google.nl/search?client...scherm+maken&sourceid=opera&ie=UTF-8&oe=UTF-8
Antwoord: https://computertotaal.nl/vraag-en-...-en-wil-print-screen-van-scherm-1-hoe-te-doen
Het is zo simpel ..... ;)
Alt+PrintScreen
Deze pakt alleen het actieve scherm mee.
Klik om te vergroten...
 
@route99, Volgens mij gaat het hier niet over het maken van een printscreen. Gaat trouwens beter met het ingebakken knipprogramma;)

@ssteenvoorde,
Misschien is deze code beter te begrijpen:
Code: 
Sub VenA()
  Sheets("rapportage voorkeur housing req").Cells(1).CurrentRegion.Resize(, 17).Copy Sheets.Add(, Sheets(Sheets.Count)).Cells(1)
  With Range("R1").Resize(, 8)
    .Value = Application.Transpose(Range("P2").Resize(8)).Value
    .Font.Bold = True
  End With
  For j = 2 To Cells(1).CurrentRegion.Rows.Count Step 8
    Range("R" & j).Resize(, 8) = Application.Transpose(Range("Q" & j).Resize(8))
  Next j
End Sub

Alle selects en copy pastespecial transpose kan je weglaten door de waarden direct dmv transpose in de cellen te zetten. Door er een lusje omheen te zetten (for j next j) gebeurt dit net zolang tot het bereik doorlopen is.
Deze methode is aanzienlijk sneller dan al het select en copy paste gedoe. Maar veel minder snel dan het geheel via array's te doen.
 
Is me heus wel duidelijk maar: Hij wilde een print screen presenteren dat niet lukte... ff teruglezen svp...
 
Beste VenA,

ik had de code in #13 inderdaad geprobeerd. Deze deed niks. Om op de vragen terug te komen, het betreft inderdaad een herhaling van 8 regels. die 1500 was eigenlijk een indicatie. De lay out van het bestand is zoals de lay out van de originele rapportage is, hier heb ik eigenlijk niks aan gewijzigd. Wat de regels uniek maken zijn de persoonsgegevens die in de eerste kolommen staan. Het kan zijn dat er later nog extra info in de lege cellen komen te staan, omdat dit een rapportage betreft van een test person. Ik ga de nieuwe code proberen. Bedankt voor jouw reactie in ieder geval.

Groet, Shin-Lee
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan