VBA excel transponse много строк в столбцы с разным размером

Question

У меня есть 88213 строк данных, которые варьируются от 11 до 21 столбца.

Традиционно копирование и вставка данных не работает.

Здесь я прочитал много сценариев, но никто не предлагает очень распространенный сценарий пересадки строк в столбцы (или столбцы в строки, если вы хотите).

Может ли кто-нибудь помочь мне, как это сделать?

Я попытался это, но цикл не работает:

Sub Transponse() 

    Dim wrkSht As Worksheet 
    Dim lLastCol As Long 
    Dim lLastRow As Long 
    Dim i As Long 

    'Work through each sheet in the workbook. 
    'For Each wrkSht In ThisWorkbook.Worksheets 
    For j = 1 To lLastRow 
     'Find the last column on the sheet. 
     lLastCol = LastCell(wrkSht).Column 

     'Work through each column on the sheet. 
     For i = 1 To lLastCol 

      'Find the last row for each column. 
      lLastRow = LastCell(wrkSht, i).Row 

      'Remove the duplicates. 
      With wrkSht 
       .Range(.Cells(1, i), .Cells(j, i)).Select 
       Selection.Copy 
       Sheets("Tabelle2").Select 
       Range(.Cells(j, 1)).Select 
       Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
       False, Transpose:=True 
      End With 
     Next i 

    Next j 
    'Next wrkSht 

    Range("A1:K1").Select 
    Selection.Copy 
    Sheets("Tabelle2").Select 
    Range("A1").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 

End Sub 

'This function will return a reference to the last cell in either the sheet, or specified column on the sheet. 
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range 

    Dim lLastCol As Long, lLastRow As Long 

    On Error Resume Next 

    With wrkSht 
     If Col = 0 Then 
      lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
      lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row 
     Else 
      lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
      lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row 
     End If 

     If lLastCol = 0 Then lLastCol = 1 
     If lLastRow = 0 Then lLastRow = 1 

     Set LastCell = wrkSht.Cells(lLastRow, lLastCol) 
    End With 
    On Error GoTo 0 

End Function 

Answer 1

Там будет построен в операции обрабатываются это в Excel ... На стороне записки, вы, вероятно, следует использовать базу данных с это много записей.

На самом деле, мне нужно обновить свой ответ. Excel поддерживает только колонки 16384. Таким образом, вы не можете перевернуть 88213 строк в пространство столбцов.

Вот спецификации Microsoft Excel на период с 2007 по 2016 ... https://support.office.com/en-us/article/excel-specifications-and-limits-1672b34d-7043-467e-8e27-269d656771c3

Вы можете также искать транспонировать Ряды в справке Excel. Вот содержание ...

Вот как:

1.Select the range of data you want to rearrange, including any row or column labels, and press Ctrl+C. 


Note: Make sure you copy the data to do this. Using the Cut command or Ctrl+X won’t work. 


2.Right-click the first cell where you want to paste the data, and pick Transpose Tranpose button image . 

Pick a spot in the worksheet that has enough room to paste your data. The data you copied will overwrite any data that’s already there. 

Paste Options menu 


3.After rotating the data successfully, you can delete the original data. 



Tips for transposing your data 

If your data includes formulas, Excel automatically updates them to match the new placement. Verify these formulas use absolute references—if they don’t, you can switch between relative, absolute, and mixed references before you rotate the data. 


If your data is in an Excel table, the Transpose feature won’t be available. You can convert the table to a range first, or you can use the TRANSPOSE function to rotate the rows and columns. 


If you want to rotate your data frequently to view it from different angles, consider creating a PivotTable so you can quickly pivot your data by dragging fields from the Rows area to the Columns area (or vice versa) in the PivotTable Field List. 

Answer 2

Это должно сделать трюк (он создает новый лист для каждого листа вы транспонирования):

Sub Transpose_All_Sheets() 
    Dim tB As Workbook 
    Dim wS As Worksheet 
    Dim DestWS As Worksheet 
    Dim LastRow As Double 
    Dim EndCol As Integer 
    Dim i As Long 
    Dim j As Long 

    Set tB = ThisWorkbook 

    For Each wS In tB.Sheets 
     If Left(wS.Name, 2) <> "T_" Then 
      Set DestWS = tB.Sheets.Add 
      DestWS.Name = "T_" & wS.Name 
      LastRow = LastRow_1(wS) 
      For i = 1 To LastRow 
       EndCol = wS.Cells(i, wS.Columns.Count).End(xlToLeft).Column 
       wS.Range(wS.Cells(i, 1), wS.Cells(i, EndCol)).Copy DestWS.Cells(1, i) 
      Next i 
     Else 
     End If 
    Next wS 

MsgBox "done" 
End Sub 

С:

Public Function LastRow_1(wS As Worksheet) As Double 
    With wS 
     If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 
      LastRow_1 = .Cells.Find(What:="*", _ 
           After:=.Range("A1"), _ 
           Lookat:=xlPart, _ 
           LookIn:=xlFormulas, _ 
           SearchOrder:=xlByRows, _ 
           SearchDirection:=xlPrevious, _ 
           MatchCase:=False).Row 
     Else 
      LastRow_1 = 1 
     End If 
    End With 
End Function 

Answer 3

Я думаю, что что-то подобное должно работать (предполагая, ваши данные на листе (1), и хочет, чтобы скопировать все на лист (2)):

Option Explicit 
Sub test() 
    Dim i As Integer 
    Dim j As Integer 
    Dim k As Integer 

    i = 1 
    While Sheets(1).Cells(1, i).Value <> "" 
     j = 1 
     While Sheets(1).Cells(j, i).Value <> "" 
      Sheets(2).Cells(i, j) = Sheets(1).Cells(j, i) 
      j = j + 1 
     Wend 
     i = i + 1 
    Wend 
End Sub 

другой версии, которая продолжается на следующий листе.

1. Знайте, что это не создает листы, поэтому вам нужно иметь необходимое количество листов, прежде чем вы позволяете ему работать.

2. не повторяет свой заголовок на листах

3. две outcommented линии для целей тестирования

   Option Explicit Sub Test() Dim я как двойной Dim J As Double дим к As Double

   i = 1 
   k = 2 
   While Sheets(1).Cells(1, i).Value <> "" 
       j = 1 
       While Sheets(1).Cells(j + (k - 2) * 16384, i) <> "" 
        If j <= (k - 1) * 16384 Then 
         'Sheets(k).Cells(i, j).Select 
         Sheets(k).Cells(i, j) = Sheets(1).Cells(j + (k - 2) * 16384, i) 
        Else 
         j = 0 
         k = k + 1 
         'Sheets(k).Activate 
        End If 
        j = j + 1 
       Wend 
       k = 2 
       i = i + 1 
   Wend 
   End Sub 
   

и небольшая вещь, чтобы очистить свои дубликаты в ваших рядах (с 82000 строк не будет так быстро):

Sub Eraser() 
    Dim i As Double 
    Dim j As Double 
    Dim k As Double 
    i = 1 
    While Sheets(1).Cells(i, 1).Value <> "" 
     j = 1 
     While Sheets(1).Cells(i, j).Value <> "" 
      k = j + 1 
      While Sheets(1).Cells(i, k).Value <> "" 
       If Sheets(1).Cells(i, j).Value = Sheets(1).Cells(i, k).Value Then 
        Sheets(1).Cells(i, k).Delete Shift:=xlToLeft 
        k = k - 1 
       End If 
       k = k + 1 
      Wend 
      j = j + 1 
     Wend 
     i = i + 1 
    Wend 
End Sub