Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender

Forumthread: VBA Code ändern, Stats nebeneinander

VBA Code ändern, Stats nebeneinander
14.05.2021 17:39:34
MPiii
Hey,
folgendes:
Ich habe einen VBA Code, der zwei Statistiken von zwei Fußballmannschaften untereinander schreibt, das sieht so aus:
https://gyazo.com/a6f0498487d9ce43b5d1dc6aa9722fc1
Ich möchte die aber nebeneinander, um besser damit kalkulieren zu können..
Das hier ist der VBA Code:

Sub get_team_data()
'''variable for saving workbook name
Dim data_workbook As String
Dim file_test As String
'''Get workbook name
data_workbook = Range("I2").Value
Dim data As Workbook
Dim extractor As Workbook
Dim league_name As Worksheet
Dim data_sheets_count As Integer
'''Set workbooks in variables
Set extractor = ThisWorkbook
Set data = Workbooks.Open(ThisWorkbook.Path & "\" & data_workbook, True, True)
Set league_name = ThisWorkbook.Sheets("league name")
'''Total sheets count in data sheet
data_sheets_count = data.Sheets.Count
'''Activate main sheet
extractor.Activate
'''Set teams sheet for saving team names
Dim league_teams_1 As Worksheet
Dim league_teams_2 As Worksheet
Dim match_sheet As Worksheet
Set league_teams_1 = ThisWorkbook.Sheets("League teams1")
Set league_teams_2 = ThisWorkbook.Sheets("League teams2")
Set match_sheet = ThisWorkbook.Sheets("Match Sheet")
match_sheet.Range("A:ZZ").ClearContents
'''get league names from sheets
Dim league_1 As String
Dim league_2 As String
league_1 = Range("C3").Value
league_2 = Range("F3").Value
'''get teams names from sheets
Dim team_1 As String
Dim team_2 As String
team_1 = Range("C5").Value
team_2 = Range("F5").Value
Dim cell_to_paste As Integer
''' For team 1
'''loop to check league name
For i = 1 To data_sheets_count
If data.Sheets(i).Name = league_1 Then
'''loop to check team name and get data
For x = 1 To data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
If data.Sheets(i).Range("B" & x).Value = team_1 Then
For y = x + 1 To data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
If data.Sheets(i).Range("B" & y).Value  "" Then
data.Sheets(i).Range("B" & x & ":ZZ" & y - 1).Copy
match_sheet.Activate
match_sheet.Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
cell_to_paste = y - x
y = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
x = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
i = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
ElseIf y = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row Then
data.Sheets(i).Range("B" & x & ":zz" & data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row).Copy
match_sheet.Activate
match_sheet.Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
cell_to_paste = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row - x
y = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
x = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
i = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
End If
Next y
End If
Next x
End If
Next i
''' For team 1
'''loop to check league name
For i = 1 To data_sheets_count
If data.Sheets(i).Name = league_2 Then
'''loop to check team name and get data
For x = 1 To data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
If data.Sheets(i).Range("B" & x).Value = team_2 Then
For y = x + 1 To data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
If data.Sheets(i).Range("B" & y).Value  "" Then
data.Sheets(i).Range("B" & x & ":ZZ" & y - 1).Copy
match_sheet.Activate
match_sheet.Range("A" & cell_to_paste + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
y = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
x = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
i = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
ElseIf y = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row Then
data.Sheets(i).Range("B" & x & ":zz" & data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row).Copy
match_sheet.Activate
match_sheet.Range("A" & cell_to_paste + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
y = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
x = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
i = data.Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row
End If
Next y
End If
Next x
End If
Next i
extractor.Sheets("Options").Activate
End Sub

Was genau muss ich ändern, dass das funktioniert?
Vielen Dank :)
Geposted bereits hier:
https://www.vba-forum.de/View.aspx?ziel=68303-VBA_Code_so_%C3%A4ndern,_dass_Daten_nebeneinander_stehen,_nicht_untereinander
Anzeige

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Code ändern, Stats nebeneinander
14.05.2021 18:42:59
GerdL
Hola,
fremde Dateeien schaue ich nicht an.
So rein nach deiner Beschreibung u. dem gezeigten Code, ersetze mal testweise
match_sheet.Range("A" & cell_to_paste + 1).Select
durch
match._sheet-Range("ZZ1").Select
Gruß Gerd
Anzeige
;

Forumthreads zu verwandten Themen

Anzeige
Anzeige
Anzeige
Anzeige
Entdecke relevante Threads

Schau dir verwandte Threads basierend auf dem aktuellen Thema an

Alle relevanten Threads mit Inhaltsvorschau entdecken
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige