• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Excel macro maken

Status
Niet open voor verdere reacties.
O

oneilboy

Gebruiker
Lid geworden
7 jun 2019
Berichten
38
Hoi,

ik ben nieuw in macro's maken en zou graag een macro maken die het volgenden doet.

bv op A1: 345 A2: 200 A3: 300 A4:
B1: 100 B2: 400 B3: B4: 350


dan moet de macro het als volgt zetten:
A 1: 345
A 2: 200
A 3: 300
A 4: 100
A 5: 400
A 6: 350

wie kan me helpen??

PS liefst macro in het Engels want mijn Excel is Engels ingesteld.
 
Bv.

Code: 
Sub hsv()
Dim sv
With Cells(1).CurrentRegion.Columns(2)
  sv = .Value
  Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sv)) = sv
 .ClearContents
End With
End Sub

Ps. macro's worden altijd in het Engels geschreven
 
Hoi,

alvast bedankt.

Ik heb nu een bijlage toegevoegd kan je die eens bekijken en eens kijken hoe de macro,eruit moet zien om dit resultaat te bekomen aub?


MVG
 

Bijlagen

Het resultaat op sheet2.

Als je de bovenste rij niet wil moet dat even aangepast worden in de code.
Code: 
Sub hsv()
Dim sv, i As Long, j As Long
sv = Sheets("sheet1").Cells(1).CurrentRegion
ReDim a(2, 0)
 For i = 2 To UBound(sv)
    a(0, UBound(a, 2)) = sv(i, 1)
    a(1, UBound(a, 2)) = sv(i, 2)
    a(2, UBound(a, 2)) = sv(i, 3)
     For j = 4 To UBound(sv, 2)
       If sv(i, j) <> "" Then
         ReDim Preserve a(2, UBound(a, 2) + 1)
          a(0, UBound(a, 2)) = sv(i, j)
        End If
      Next j
     ReDim Preserve a(2, UBound(a, 2) + 1)
    Next i
  With Sheets("sheet2")
    .Cells(1).Resize(, 13) = Sheets("sheet1").Cells(1).Resize(, 13).Value
    .Cells(2, 1).Resize(UBound(a, 2), 3) = Application.Transpose(a)
  End With
End Sub
 
Hoi,

kan je aub de macro aanpassen om op de bijlage toe te passen?

MVG
 

Bijlagen

Ik dacht dat ik een bericht zag dat alles TOP was.

Het resultaat op sheet2.
Code: 
Sub hsv()
Dim sv, i As Long, j As Long, jj As Long
sv = Sheets("sheet1").Cells(1).CurrentRegion
ReDim a(8, 0)
 For i = 2 To UBound(sv)
   For jj = 1 To 9
      a(jj - 1, UBound(a, 2)) = sv(i, jj)
     Next jj
     For j = 10 To UBound(sv, 2)
       If sv(i, j) <> "" Then
         ReDim Preserve a(8, UBound(a, 2) + 1)
          a(0, UBound(a, 2)) = sv(i, j)
        End If
      Next j
     ReDim Preserve a(8, UBound(a, 2) + 1)
    Next i
  With Sheets("sheet2")
    .Cells(1).Resize(, 9) = Sheets("sheet1").Cells(1).Resize(, 9).Value
    .Cells(2, 1).Resize(UBound(a, 2), 9) = Application.Transpose(a)
  End With
End Sub
 
hoi,

super echt TOP !!!!

werkt perfect en zal me veel tijd uitsparen
 
Het kan nog wel met een regeltje minder.
Code: 
Sub hsv()
Dim sv, i As Long, j As Long, jj As Long
sv = Sheets("sheet1").Cells(1).CurrentRegion
ReDim a(8, 0)
 For i = 1 To UBound(sv)
   For jj = 1 To 9
      a(jj - 1, UBound(a, 2)) = sv(i, jj)
     Next jj
     For j = 10 To UBound(sv, 2)
       If i > 1 And sv(i, j) <> "" Then
         ReDim Preserve a(8, UBound(a, 2) + 1)
          a(0, UBound(a, 2)) = sv(i, j)
        End If
      Next j
     ReDim Preserve a(8, UBound(a, 2) + 1)
    Next i
 Sheets("sheet2").Cells(1).Resize(UBound(a, 2), 9) = Application.Transpose(a)
End Sub
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan