使用VBA从列到行将Excel数据剪切和粘贴的自动化过程

Question

I'm trying to create VBA code to cut and paste data from BCol1,BCol2,BCol3 into row directly beneath that record under ACol1,ACol2,ACol3. Likewise for CCol1,CCol2,CCol3 and so on. Also I want common column data to be copied in first column for that specific record.

I would like to create a code that loops for an entire set of data as I've 100+ columns, 10000+ rows and 50000+ Excel files to process data. I need an automated solution.

I can't open each Excel file and implement VBA code, so any pointer for that is also appreciated.

This is how my sample data looks

This is how my sample data should look like

[Edit:] I've tried the following code:

Sub cut_paste()
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column

For i = lastRow To 2 Step -1
    Rows(i + 1).Insert
    Rows(i + 1).Insert
    Rows(i + 1).Insert
Next i

For j = 2 To 4 * (lastRow - 1) + 1 Step 4
    Range("E" & j).Select
    Selection.Cut
    Range("B" & j + 1).Select
    ActiveSheet.Paste
    Range("F" & j).Select
    Selection.Cut
    Range("C" & j + 1).Select
    ActiveSheet.Paste
    Range("G" & j).Select
    Selection.Cut
    Range("D" & j + 1).Select
    ActiveSheet.Paste

    Range("H" & j).Select
    Selection.Cut
    Range("B" & j + 2).Select
    ActiveSheet.Paste
    Range("I" & j).Select
    Selection.Cut
    Range("C" & j + 2).Select
    ActiveSheet.Paste
    Range("J" & j).Select
    Selection.Cut
    Range("D" & j + 2).Select
    ActiveSheet.Paste

    Range("K" & j).Select
    Selection.Cut
    Range("B" & j + 3).Select
    ActiveSheet.Paste
    Range("L" & j).Select
    Selection.Cut
    Range("C" & j + 3).Select
    ActiveSheet.Paste
    Range("M" & j).Select
    Selection.Cut
    Range("D" & j + 3).Select
    ActiveSheet.Paste
Next j

For k = 2 To 4 * (lastRow - 1) + 1 Step 4
    Range("A" & k).Select
    Selection.Copy
    For l = k + 1 To k + 3 Step 1
        Range("A" & l).Select
        ActiveSheet.Paste
    Next l
Next k
End Sub

I'm able to do this for sample data but for actual data its hectic task to do this way.

Thanks for any help!

Answer 1

here is a vba procedure that you can adapt to your needs

Sub aargh()
    sourcePath = "c:\sourcepath\"
    destpath = "c:\destpath\"
    f = Dir(sourcePath & "\*.xls*")
    While f <> "" 'loop tru all xls files in source directory
        Workbooks.Open (sourcePath & f) 
        lastrow = Cells(Rows.Count, "A").End(xlUp).Row
        lastcolumn = Cells(1, Columns.Count).End(xlToLeft).Column
        ' copy range to array a
        a = Range(Range("A1"), Cells(lastrow, lastcolumn))
        Cells.ClearContents
        For i = LBound(a, 1) + 1 To UBound(a, 1)
            For j = LBound(a, 2) + 1 To UBound(a, 2) Step 3
                li = li + 1
                Cells(li, 1) = a(i, LBound(a, 2))
                For k = 1 To 3
                    Cells(li, k + 1) = a(i, LBound(a, 2) + k + j - 2)
                Next k
            Next j
        Next i
        ' save modified file as new file
        ActiveWorkbook.SaveAs destpath & f
        f = Dir()
    Wend
End Sub

Answer 2

To do it a bit variable, you can use something like this:

Option Explicit

Sub dada()
  Dim left_part As Long, split_part As Long, num_parts As Long, x, y

  x = Selection.Value2
  left_part = 1
  split_part = 3

  num_parts = (UBound(x, 2) - left_part) / split_part
  ReDim y(1 To num_parts * UBound(x), 1 To left_part + split_part)

  Dim i As Long, j As Long, k As Long, l As Long

  For i = 1 To UBound(x)
    For j = 1 To num_parts

      l = l + 1

      For k = 1 To left_part
        y(l, k) = x(i, k)
      Next

      For k = 1 To split_part
        y(l, k + left_part) = x(i, k + (j - 1) * split_part + left_part)
      Next

    Next
  Next

  Sheets.Add.Cells(2, 1).Resize(UBound(y), UBound(y, 2)) = y

End Sub

Just set left_part to the count of columns which will not be split. (in your example this is just common1, common2....) so if there are multiple columns then change that. Also set split_part to the size of the parts to split. (in your example this is 3 for *Col1, *Col2 and *Col3) ao if that differs, just change that to your needs.

Now select your range to split without the upper headers (will be A2:M4 in your example) and run the macro.

You also can set x to x = [A2:M4].Value2 or whatever you need if you do not want to select the range.

After splitting everything up, it will be pasted in a new sheet without formatting. But having everything below each other should make it easy to to copy the formats to the columns as you need them (or after copying the date wherever you want it).

Just keep in mind to also copy the headers later on (as they seem to change in an unknown way, I've excluded them here)

If anything does not work as you want it or if you just have any questions, just ask ;)

hint: every interaction with the sheet will be MUCH slower then doing this just with variables. This way (for mid-ranged tables), executing this code and formatting it manually afterwards will be faster then copy/pasting via macro)