Wer kann mir Makro umstellen ?
15.09.2003 09:53:28
Gery
Ich möchte gern aus einem Tabellenblatt alle Werte auslesen und in ein Neues übertragen. Leider bekomme ich mit folgendem Makro nur Spalte A u. B (Text)spalte C wird mit 0 ausgefüllt(darin stehen andere Zahlen) und alles was danach bis spalte R kommt ist weg. *die Werte werden teilweise per Formel aus anderen verknüpften, nicht geöffneten tabellen geholt!
Kann man mir jemand helfen ?
Option Explicit
Sub TabUmwandeln()
Dim wks As Worksheet
Dim var As Variant
Dim intLastRow As Integer, intRow As Integer, _
intCol As Integer, intRowT As Integer
Dim intColT As Integer
Dim strLager As String
intLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set wks = ActiveSheet
Worksheets.Add.Move after:=Worksheets(wks.Index)
intRowT = 1
For intRow = 1 To intLastRow
If IsEmpty(wks.Cells(intRow, 2)) Then
If IsEmpty(Range("R1")) Then
intCol = 2
Else
intCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
End If
Cells(1, intCol).Value = wks.Cells(intRow, 1).Value
strLager = wks.Cells(intRow, 1).Value
Else
var = Application.Match(wks.Cells(intRow, 1).Value, Columns(1), 0)
If IsError(var) Then
intRowT = intRowT + 1
Cells(intRowT, 1).Value = wks.Cells(intRow, 1).Value
Cells(intRowT, 2).Value = wks.Cells(intRow, 2).Value
Else
intColT = WorksheetFunction.Match(strLager, Rows(1), 0)
Cells(var, intColT).Value = _
Cells(intRowT, intColT).Value + wks.Cells(intRow, 2).Value
End If
End If
Next intRow
Cells(1, intCol + 1).Value = "Gesamt"
intRow = 2
Do Until IsEmpty(Cells(intRow, 1))
Cells(intRow, intCol + 1).Value = _
WorksheetFunction.Sum(Range(Cells(intRow, 2), Cells(intRow, intCol)))
intRow = intRow + 1
Loop
Rows(1).Font.Bold = True
Rows(1).HorizontalAlignment = xlRight
End Sub