Excel macro maken

[oneilboy]

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.

 

[HSV]

Bv.

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

 

[oneilboy]

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

 

[HSV]

Het resultaat op sheet2.

Als je de bovenste rij niet wil moet dat even aangepast worden in de 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

 

[oneilboy]

Hoi,

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

MVG

 

[HSV]

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

Het resultaat op sheet2.

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

 

[oneilboy]

hoi,

super echt TOP !!!!

werkt perfect en zal me veel tijd uitsparen

 

[HSV]

Het kan nog wel met een regeltje minder.

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

 

[oneilboy]

Super, dank je wel