Office中国论坛/Access中国论坛

标题: 由于每次原始数据的名称都不一样，如何每次自动获取名称？ [打印本页]

作者: 棋行天下黄 时间: 2009-6-9 23:25
标题: 由于每次原始数据的名称都不一样，如何每次自动获取名称？
由于每次原始数据的名称都不一样，如何每次自动获取名称？Sub Macro1()
'
' Macro1 Macro
' 宏由黄勇录制，时间: 2009-6-9
'
' 快捷键: Ctrl+k
'
ChDir "C:\Documents and Settings\Administrator\My Documents\宏标卡"
Workbooks.Open Filename:= _
"C:\Documents and Settings\Administrator\My Documents\宏标卡\门店标卡（武汉）.xls"
ActiveWindow.SmallScroll Down:=-48
Range("A1:C42").Select
Range("A40").Activate
Selection.Copy
Windows("原始数据.xls").Activate
Sheets.Add
ActiveSheet.Paste
Windows("门店标卡（武汉）.xls").Activate
Sheets("品类对应部门").Select
ActiveWindow.SmallScroll Down:=-21
Range("A1:C43").Select
Range("C15").Activate
Application.CutCopyMode = False
Selection.Copy
Windows("原始数据.xls").Activate
Sheets.Add
ActiveSheet.Paste
Sheets("原始数据").Select
Windows("门店标卡（武汉）.xls").Activate
ActiveWindow.Close
End Sub
需要完整代码代替上面原始数据的名字，即任意文件名按ctrl+k即可，谢谢

作者: 方漠 时间: 2009-6-9 23:44
Here is a sample for you, try to get the variant with Activesheet.name/activeworkbook.name/activewindow.name.

Sub FormatBalance()

Dim Str As String
Dim ab As Variant
Dim Lrow As Long, I As Long, T As Long
Dim Fcl As Range

Str = Workbooks.Application.GetOpenFilename
ab = Str
  If ab = False Then
MsgBox "You didn't select the TXT file. Cancelling...", vbExclamation, "Your Company Name"
  Else
   Application.DisplayAlerts = False
   Application.ScreenUpdating = False

Workbooks.OpenText Filename:=Str, Origin:=-536, _
      StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
      ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
      , Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 1 _
      ), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
      Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), TrailingMinusNumbers:=True

Lrow = Range("A65536").End(xlUp).Row
T = 8
For I = 8 To Lrow                         'Remove the Redundant Line
If Left(Range("A" & I), 9) = "---------" Then
   Rows(I & ":" & I).Delete
   I = I - 1
End If

If I > 25 And Left(Range("A" & I), 3) <> "832" Then
         Rows(I & ":" & I).Delete
         I = I - 1
End If

T = T + 1
If T > Lrow Then Exit For
Next I

For Each Fcl In ActiveSheet.UsedRange 'Remove the Redundant Blank
Fcl = Trim(Fcl.Value)
Next

Range("A9:A10").Merge
Range("B9:B10").Merge
Range("C9:C10").Merge
Range("L9

10").Merge
Range("A9

10").Select

With Selection.Interior
      .ColorIndex = 12
      .Pattern = xlSolid
End With

With Selection.Font
      .Name = "Arial"
      .Size = 10
      .ColorIndex = 2
      .Bold = True
End With

With Selection
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
End With
Columns("A:A").ColumnWidth = 9.5
Columns("B

").EntireColumn.AutoFit

I = Range("C65536").End(xlUp).Row

Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Range("H9:H10").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Merge
ActiveCell.FormulaR1C1 = "Diff +/-"
Range("H11:H" & I).Select
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"
Selection.FillDown

Range("M9

10").Select
Selection.FillRight
Range("N9:N10").FormulaR1C1 = "Remark"
Range("O9:O10").FormulaR1C1 = "Found date"
Range("

10").FormulaR1C1 = "Status"
Range("

" & I).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""","""",TODAY()-RC[-1])"
Selection.FillDown
Columns("N:N").ColumnWidth = 15
Columns("O:O").ColumnWidth = 12
Columns("D:E").EntireColumn.Hidden = True
Columns("M:M").EntireColumn.Hidden = True
Columns("I:L").ColumnWidth = 10
Range("A11").Select

   Application.DisplayAlerts = True
   Application.ScreenUpdating = False

End If

End Sub

作者: 棋行天下黄 时间: 2009-6-10 21:13
你是我见过的真正的高手，佩服得六体投地，在你的指导下，我已将宏重新修改，自动打开宏标卡（在你的电脑上路径要修改一下），可以识别不同的文件名，但是运行错误在Selection.AutoFilter处，不知所以，请不吝赐教再指点，最好是全部源码，你真是个好人！！
Sub Macro1()
'
' Macro1 Macro
' 宏由黄勇录制，时间: 2009-6-10
'
' 快捷键: Ctrl+k
Dim strA As String
strA = ThisWorkbook.Name

   ChDir "C:\Documents and Settings\Administrator\My Documents\宏标卡"
Workbooks.Open Filename:= _
      "C:\Documents and Settings\Administrator\My Documents\宏标卡\门店标卡（武汉）.xls"

   Windows(strA).Activate
   Range("A2").Select
Selection.Insert Shift:=xlDown
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="1"
Cells.Select
Range("A2").Activate
Selection.Copy

Sheets.Add
ActiveSheet.Paste
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False
Range("B2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'[门店标卡（武汉）.xls]品类对应部门'!C1:C2,2,0)"
Selection.AutoFill Destination:=Range("B2:B100"), Type:=xlFillDefault
Range("B2:B100").Select
ActiveWindow.SmallScroll Down:=-84
Range("B1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="<>#N/A", Operator:=xlAnd
Cells.Select
Range("B1").Activate
Selection.Copy
Sheets("Sheet1").Select
Sheets.Add
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=False
Sheets("Sheet2").Select
Sheets.Add
Application.CutCopyMode = False
Selection.Consolidate Sources:= _
      "'Sheet2'!R1C2:R148C136" _
      , Function:=xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Range("B2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'[门店标卡（武汉）.xls]品类对应部门'!C2:C3,2,0)"
Selection.AutoFill Destination:=Range("B2:B12"), Type:=xlFillDefault
Range("B2:B12").Select
Range("A1").Select
ActiveCell.FormulaR1C1 = "品类"
Range("B1").Select
ActiveCell.FormulaR1C1 = "序号"
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
      :=xlPinYin
Rows("1:22").Select
Selection.Copy
Sheets.Add
Sheets("Sheet4").Select
ActiveWindow.SmallScroll Down:=-15
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=True
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False
Range("A1").Select
Sheets("Sheet4").Select
Sheets.Add
Range("A1").Select
ActiveCell.FormulaR1C1 = "='[门店标卡（武汉）.xls]门店顺序'!RC"
Range("A1").Select
Selection.AutoFill Destination:=Range("A1:C1"), Type:=xlFillDefault
Range("A1:C1").Select
Selection.AutoFill Destination:=Range("A1:C100"), Type:=xlFillDefault
Range("A1:C100").Select
ActiveWindow.SmallScroll Down:=-135
Sheets("Sheet4").Select
Range("B1:K1").Select
Selection.Copy
Sheets("Sheet5").Select
Range("D1").Select
ActiveSheet.Paste
Range("D2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,2,0)"
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,2,0)/10000"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:M2"), Type:=xlFillDefault
Range("D2:M2").Select
ActiveWindow.ScrollColumn = 1
Range("E2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,3,0)/10000"
Range("F2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,4,0)/10000"
Range("G2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,5,0)/10000"
Range("H2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,6,0)/10000"
Range("I2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,7,0)/10000"
Range("J2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,8,0)/10000"
Range("K2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,9,0)/10000"
Range("L2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,10,0)/10000"
Range("M2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Sheet4!C1:C11,11,0)/10000"
Range("D2:M2").Select
Range("M2").Activate
ActiveWindow.ScrollColumn = 4
Selection.AutoFill Destination:=Range("D2:M100"), Type:=xlFillDefault
Range("D2:M100").Select
Cells.Select
Range("M2").Activate
ActiveWindow.ScrollColumn = 1
ActiveWindow.SmallScroll Down:=-126
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=False
Application.CutCopyMode = False
Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False
ActiveWindow.ScrollColumn = 1
With Selection.Font
      .Name = "宋体"
      .Size = 10
      .Strikethrough = False
      .Superscript = False
      .Subscript = False
      .OutlineFont = False
      .Shadow = False
      .Underline = xlUnderlineStyleNone
      .ColorIndex = xlAutomatic
End With
Selection.NumberFormatLocal = "0.00_ "
ActiveWindow.ScrollColumn = 1
Columns("A:C").Select
Selection.Replace What:="0", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False
ActiveWindow.ScrollColumn = 4
ActiveWindow.SmallScroll ToRight:=2
Range("N1").Select
ActiveCell.FormulaR1C1 = "合计"
Range("N2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-10]:RC[-1])"
Range("N2").Select
Selection.AutoFill Destination:=Range("N2:N42"), Type:=xlFillDefault

Range("A43").Select
ActiveCell.FormulaR1C1 = "合计"
Range("D43").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-41]C:R[-1]C)"
Range("D43").Select
ActiveWindow.SmallScroll Down:=3
Range("D43").Select
Selection.AutoFill Destination:=Range("D43:N43"), Type:=xlFillDefault
Range("D43:N43").Select
ActiveWindow.SmallScroll Down:=-42
ActiveWindow.ScrollColumn = 1

Sheets("Sheet5").Select
Sheets("Sheet5").Name = "报表"
Sheets("Sheet4").Select
ActiveWindow.SelectedSheets.Visible = False
ActiveWindow.SelectedSheets.Visible = False
ActiveWindow.SelectedSheets.Visible = False
ActiveWindow.SelectedSheets.Visible = False
Sheets("报表").Select
End Sub

作者: pureshadow 时间: 2009-6-11 21:18
放到表中测试了，没有发生问题。
不过录出来的代码有时会因为工作表未指定而产生错误了。
本来想帮你改一下，后来仔细看了一下，楼主不就是要做到个转置的效果么，这个似乎用不着这么复杂的代码，也许是我眼花……

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)