另一个用于excel 2007的OPTIMIZING宏vba代码。代码是一种用于我的数据的转移器 [英] Another OPTIMIZING macro vba code for excel 2007. the code is a sort of transposer for my data

问题描述

你好这个代码最初没有完成，这里有一些thigns，我不太明白，我已经改变了一点从我的同事代码，以适应我的数据，它的工作原理。但太慢当我有4000 + kb的excel文件，它可能会完全冻结。 （我已经检查过，当这个转座运行的时候，它仍然在excel行限制之内，我以前做了计算，并且做了一个宏，根据列和行的数量自动分割excel文件，以确保这样） 。该代码似乎开始快，然后运行的时间越长。至少这是对我来说似乎是谎言。

随时建议任何方法使此代码更快/更好！感谢您的时间。
对不起，我不明白这个代码超级好。

我已经关闭屏幕更新，自动计算等等。

  Dim InitRange As Range 
 Dim Counter As Range 
 Dim paracount As Long 
 Dim Filler As Range 
 Dim ParaSelect As Range 
 Dim Paraloc As Range 
 Dim Paravalloc As Range 
 Dim Unitloc As Range 
 Dim methodloc As Range 
 Dim CurNum As Long 
 Dim MaxNum As Long 
 Dim eCell As Range 
 Dim checkRow As Long 
 Dim InsertRow As Long 
 Dim x As Long 
 Dim y As Long 
 Dim vRow As Long 
 
 CurNum = 0 
 MaxNum = 0 
 
x = 1 
 
范围（K1）。结束（xlToRight）.Offset（0，0）。选择
 
设置ParaSelect = Range（K1，ActiveCell）
 InsertRow = ParaSelect.Count  -  1 
 
设置InitRange =范围（A4，F4）
设置计数器= InitRange 
 
 Do 
 MaxNum = MaxNum + 1 
 InitRange.Offset（MaxNum，0）.Activate 
循环直到ActiveCell =
 
 
设置eCell = InitRange.Offset（0，0）
 
 Do $ b $ Cell.Offset（x，0）.Activate 
 Rows（eCell.Offset（x，0）.row& ：& eCell.Offset（x，0）.row + InsertRow  -  1）.Insert 
 x = x + InsertRow + 1 
如果x> MaxNum *（InsertRow + 1）然后退出Do 
循环
 
范围（A1）。激活
 
 Set Filler = InitRange 
 
设置Paraloc = Range（G4）
设置Paravalloc = Range（H4）
设置Unitloc = Range（I4）
设置methodloc = Range（J4）
 
 vRow = 0 
y = 0 
 Do 
 
 ParaSelect.Copy 
 Paraloc.Offset（y，0）.PasteSpecial xlPasteValues，Transpose： = True 
 
 ParaSelect.Offset（1，0）.Copy 
 methodloc.Offset（y，0）.PasteSpecial xlPasteValues，Transpose：= True 
 
 ParaSelect。 Offset（2，0）.Copy 
 Unitloc.Offset（y，0）.PasteSpecial xlPasteValues，Transpose：= True 
 
 ParaSelect.Offset（CurNum *（InsertRow + 1）+ 3， 0）.Copy 
 Paravalloc.Offset（y，0）.PasteSpecial xlPasteValues，Transpose：= True 
 
 Filler.Offset（y，0）.Copy 
 CurNum = CurNum + 1 
y = y + 1 
 checkRow = 1 
 Do 
 Filler.Offset（y，0）.PasteSpecial xlPasteValues 
y = y + 1 
填充。偏移（y，0）。激活
 checkRow = checkRow + 1 
 
循环直到checkRow> InsertRow 
循环直到CurNum> = MaxNum 
  

Jon做了一个很好的建议>我的应该defiantely提供一些东西来告诉你们这些代码是什么。图片1是转换前文件的样子

图片2是转换后的文件。没有后顾之忧将被删除。

注意：文件可能有任意数量的列和行

解决方案

在没有实际工作簿的情况下，我很难弄清楚你正在尝试什么。所以我尽了最大努力，希望没有错误。如果我有实际的工作簿或一个例子，我可能会给你一个非常好的优化代码。这是我的第一个通行证：

  Dim InitRange As Range，Counter As Range，Filler As Range，ParaSelect As Range，Paraloc As Range 
 Dim Paravalloc As Range，methodloc As Range，methodloc As Range，eCell As Range 
 Dim paracount As Long，CurNum As Long，MaxNum As Long，checkRow As Long，InsertRow As Long 
 Dim x As Long，y As Long，vRow As Long 
 
 CurNum = 0 
 
x = 1 
 
设置ParaSelect = Range（K1，Range（ K1）结束（xlToRight））
 InsertRow = ParaSelect.Count  -  1 
 
设置InitRange = Range（A4，F4）
设置Counter = InitRange 
 
 MaxNum = InitRange.Resize（1，1）.End（xlDown）.row  -  4 
 
设置eCell = InitRange 
 
'不确定你试图在这里完成，所以我将原始代码（除了非必需代码。
 Do 
 Rows（eCell.Offset（x，0）.row&：& eCell。 Offset（x，0）.row + InsertRow  -  1）.Insert 
x = x + Ins ertRow + 1 
如果x> MaxNum *（InsertRow + 1）然后退出Do 
循环
 
 Set Filler = InitRange 
 
设置Paraloc = Range（G4）
设置Paravalloc = Range（H4）
 Set Unitloc = Range（I4）
设置methodloc = Range（J4）
 
 vRow = 0 
y = 0 
 
 Do 
 
 ParaSelect.Copy 
 Paraloc.Offset（y，0）.PasteSpecial xlPasteValues，Transpose：= True 
 
 ParaSelect。 Offset（1，0）.Copy 
 methodloc.Offset（y，0）.PasteSpecial xlPasteValues，Transpose：= True 
 
 ParaSelect.Offset（2，0）.Copy 
 Unitloc.Offset（y，0）.PasteSpecial xlPasteValues，Transpose：= True 
 
 ParaSelect.Offset（CurNum *（InsertRow + 1）+ 3，0）.Copy 
 Paravalloc.Offset y，0）.PasteSpecial xlPasteValues，Transpose：= True 
 
 Filler.Offset（y，0）.Copy 
 CurNum = CurNum + 1 
y = y + 1 
 checkRow = 1 
 Do 
 Filler.Offset（y，0）。 PasteSpecial xlPasteValues 
 y = y + 1 
 checkRow = checkRow + 1 
循环直到checkRow> InsertRow 
循环直到CurNum> = MaxNum 
  

好的，这应该是非常有效的。确保你先测试一下，不知道我是否有任何偏移。

  Sub TransposeIt（） 
 
 Dim i As Long，j As Long，k As Long 
 Dim rData As Range 
 Dim sData（）As String，sName As String 
 Dim wks As Worksheet 
 Dim vData As Variant 
 
 Application.ScreenUpdating = False 
 Application.EnableEvents = False 
'初始化工作表
设置wks = ActiveSheet 
 
'获取数据
设置rData = wks.UsedRange 
 vData = rData 
 ReDim sData（1到10，1到rData.Columns.Count  -  10）
 rData。 Offset（1）.Clear 
 rData.Offset（10）.Resize（1）.Clear 
 
 For i = 1 To UBound（vData）
对于j = 1到UBound （sData）
对于k = 1到6 
 sData（j，k）= vData（i，k）
下一个k 
 sData（j，7）= vData ，j + 10）
 sData（j，8）= vData（i，j + 10）
 sData（j，9）= vData（3，j + 10）
 sData（j，10）= vData（2，j + 10）
下一步j 
'打印转置数据
 wks.Range一个& Application.Rows.Count）.End（xlUp）_ 
 .Offset（1）.Resize（UBound（sData），UBound（sData，2））= sData 
下一个i 
 
 Application.ScreenUpdating = True 
 Application.EnableEvents = True 
 
 End Sub 
  

Hello this code was not done by me originally and there are some thigns here i dont quite understand i have altered it a bit from my coworkers code to suit my data and it works. but too slow. and when i have 4000+kb excel files it might freeze altogether. ( I have checked tho that when and after this transposer runs it will still be within the excel row limit, i had done calculations before and made a macro to automatically split excel files based on number of columns and rows to make sure this is so ). This code seems to start out fast then goes slower the longer it runs. at least this is what it seems liek to me.

Feel free to suggest any ways to make this code faster/better! Thank you for your time. Sorry that I dont understand this code super well.

i have turned off screen updating, automatic calculation, etc etc.

Dim InitRange As Range
Dim Counter As Range
Dim paracount As Long
Dim Filler As Range
Dim ParaSelect As Range
Dim Paraloc As Range
Dim Paravalloc As Range
Dim Unitloc As Range
Dim methodloc As Range
Dim CurNum As Long
Dim MaxNum As Long
Dim eCell As Range
Dim checkRow As Long
Dim InsertRow As Long
Dim x As Long
Dim y As Long
Dim vRow As Long

CurNum = 0
MaxNum = 0

x = 1

Range("K1").End(xlToRight).Offset(0, 0).Select

Set ParaSelect = Range("K1", ActiveCell)
InsertRow = ParaSelect.Count - 1

Set InitRange = Range("A4", "F4")
Set Counter = InitRange

Do
MaxNum = MaxNum + 1
InitRange.Offset(MaxNum, 0).Activate
Loop Until ActiveCell = ""


Set eCell = InitRange.Offset(0, 0)

Do
eCell.Offset(x, 0).Activate
Rows(eCell.Offset(x, 0).row & ":" & eCell.Offset(x, 0).row + InsertRow - 1).Insert
x = x + InsertRow + 1
If x > MaxNum * (InsertRow + 1) Then Exit Do
Loop

Range("A1").Activate

Set Filler = InitRange

Set Paraloc = Range("G4")
Set Paravalloc = Range("H4")
Set Unitloc = Range("I4")
Set methodloc = Range("J4")

vRow = 0
y = 0
Do

ParaSelect.Copy
Paraloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

ParaSelect.Offset(1, 0).Copy
methodloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

ParaSelect.Offset(2, 0).Copy
Unitloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

ParaSelect.Offset(CurNum * (InsertRow + 1) + 3, 0).Copy
Paravalloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

Filler.Offset(y, 0).Copy
CurNum = CurNum + 1
y = y + 1
checkRow = 1
Do
Filler.Offset(y, 0).PasteSpecial xlPasteValues
y = y + 1
Filler.Offset(y, 0).Activate
checkRow = checkRow + 1

Loop Until checkRow > InsertRow
Loop Until CurNum >= MaxNum

Jon made a good suggestiong >.> i should defiantely provide something to show you guys what this code is about. Picture 1 is what the file looks like before it is transposed

Picture 2 is what the files looks like after it is transposed. No worries column k and after will be deleted.

NOTE: The files may have any number of columns and rows

解决方案

It's hard for me to figure out exactly what you are trying to do here without the actual workbook. So I did my best, hopefully there are no errors. If I had the actual workbook or an example I could probably get you a really nice optimized code. Here's my first pass:

    Dim InitRange As Range, Counter As Range, Filler As Range, ParaSelect As Range, Paraloc As Range
    Dim Paravalloc As Range, Unitloc As Range, methodloc As Range, eCell As Range
    Dim paracount As Long, CurNum As Long, MaxNum As Long, checkRow As Long, InsertRow As Long
    Dim x As Long, y As Long, vRow As Long

    CurNum = 0

    x = 1

    Set ParaSelect = Range("K1", Range("K1").End(xlToRight))
    InsertRow = ParaSelect.Count - 1

    Set InitRange = Range("A4", "F4")
    Set Counter = InitRange

    MaxNum = InitRange.Resize(1, 1).End(xlDown).row - 4

    Set eCell = InitRange

    'Not sure what you are trying to accomplish here so I'll the original code (except for non essential code.
    Do
        Rows(eCell.Offset(x, 0).row & ":" & eCell.Offset(x, 0).row + InsertRow - 1).Insert
        x = x + InsertRow + 1
        If x > MaxNum * (InsertRow + 1) Then Exit Do
    Loop

    Set Filler = InitRange

    Set Paraloc = Range("G4")
    Set Paravalloc = Range("H4")
    Set Unitloc = Range("I4")
    Set methodloc = Range("J4")

    vRow = 0
    y = 0

    Do

        ParaSelect.Copy
        Paraloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

        ParaSelect.Offset(1, 0).Copy
        methodloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

        ParaSelect.Offset(2, 0).Copy
        Unitloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

        ParaSelect.Offset(CurNum * (InsertRow + 1) + 3, 0).Copy
        Paravalloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

        Filler.Offset(y, 0).Copy
        CurNum = CurNum + 1
        y = y + 1
        checkRow = 1
        Do
            Filler.Offset(y, 0).PasteSpecial xlPasteValues
            y = y + 1
            checkRow = checkRow + 1
        Loop Until checkRow > InsertRow
    Loop Until CurNum >= MaxNum

OK, this should be pretty efficient. Make sure you test it first, don't know if I got any of my offsets off at all.

Sub TransposeIt()

    Dim i As Long, j As Long, k As Long
    Dim rData As Range
    Dim sData() As String, sName As String
    Dim wks As Worksheet
    Dim vData As Variant

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    'Initialize worksheets
    Set wks = ActiveSheet

    'Get data
    Set rData = wks.UsedRange
    vData = rData
    ReDim sData(1 To 10, 1 To rData.Columns.Count - 10)
    rData.Offset(1).Clear
    rData.Offset(10).Resize(1).Clear

    For i = 1 To UBound(vData)
        For j = 1 To UBound(sData)
            For k = 1 To 6
                sData(j, k) = vData(i, k)
            Next k
            sData(j, 7) = vData(1, j + 10)
            sData(j, 8) = vData(i, j + 10)
            sData(j, 9) = vData(3, j + 10)
            sData(j, 10) = vData(2, j + 10)
        Next j
        'Print transposed data
        wks.Range("A" & Application.Rows.Count).End(xlUp) _
           .Offset(1).Resize(UBound(sData), UBound(sData, 2)) = sData
    Next i

    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

这篇关于另一个用于excel 2007的OPTIMIZING宏vba代码。代码是一种用于我的数据的转移器的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！