Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1828to1832
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

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

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

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige