无论 VBA 中的语言设置如何,都将数据导出到新工作簿
Exporting data to new Workbook regardless of language settings in VBA
我有一个代码可以从当前工作簿(多个工作sheets)收集数据并以预定义的方式将该数据导出到新工作簿。
问题: 我用英文编写代码,所以我按名称引用了一些输出 sheets(例如 Sheet1)。但是,我希望此代码可以在 excel 中与其他语言首选项(例如 tabela1、tabelle1...)一起使用。如果我引用 "Sheet1",当用户处于不同的语言设置 excel 时,创建的新工作簿将具有不同名称的 sheet。
问题:我该如何解决这种情况?
已经试过: 代替原来的:
w2.Sheets("Sheet1").Range...
我尝试使用:
w2.Worksheets(1).Range...
但显然这不起作用(下标超出范围错误)
Obs1: 我也试过在新的工作簿中添加一个新的工作sheet,指定名称,并保持原来的代码,但是这种做法没那么优雅
Obs2: 代码的相关部分是将标识符、日期和内容数组粘贴到新的 sheet.
代码:
Function ArrayFiller(arr As Variant, arr0 As Variant, y As String, Optional ind As Boolean) As Variant
Dim lRow As Long, lColumn As Long
Dim w2 As Workbook
Dim w3 As Workbook
Dim d As Date, d1 As Long, d2 As Long
Dim CompArray() As Variant
Workbooks.Add
Set w2 = ActiveWorkbook
For lRow = LBound(arr, 1) To UBound(arr, 1)
For lColumn = LBound(arr, 2) + 1 To UBound(arr, 2)
If arr(lRow, lColumn) <> "" And arr(lRow, lColumn - 1) = "" Then
If arr0(lRow, lColumn) <> "" And arr0(lRow, lColumn) <> "--" Then
arr(lRow, lColumn - 1) = arr0(lRow, lColumn)
w2.Worksheets(1).Cells(lColumn - 1, lRow).Interior.Color = RGB(255, 0, 0)
ElseIf arr0(lRow, lColumn) = "" Or arr0(lRow, lColumn) = "--" Then
arr(lRow, lColumn - 1) = arr(lRow, lColumn)
w2.Worksheets(1).Cells(lColumn - 1, lRow).Interior.Color = RGB(255, 0, 0)
End If
End If
Next
Next
w2.Sheets("Sheet1").Range("A1").Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.WorksheetFunction.Transpose(arr)
Columns(2).EntireColumn.Delete
Rows(2).EntireRow.Delete
d = Application.WorksheetFunction.WorkDay(w2.Sheets("Sheet1").Range("A3"), -1)
w2.Sheets("Sheet1").Range("A2") = d
w2.SaveAs Filename:=ThisWorkbook.path & "\" & "Output" & y, FileFormat:=6
CompArray() = w2.Worksheets(1).UsedRange.Value
w2.Close True
d1 = UBound(CompArray, 1)
d2 = UBound(CompArray, 2)
If ind = True Then
Workbooks.Add
Set w3 = ActiveWorkbook
For lRow = LBound(CompArray, 1) + 1 To UBound(CompArray, 1)
For lColumn = LBound(CompArray, 2) + 1 To UBound(CompArray, 2)
If CompArray(lRow, lColumn) <> "" And CompArray(lRow, lColumn) <> "--" Then
w3.Worksheets(1).Cells(lRow, lColumn).Value = 1
Else
w3.Worksheets(1).Cells(lRow, lColumn).Value = 0
End If
Next
Next
Columns(1).EntireColumn.Insert
Rows(1).EntireRow.Insert
w3.Sheets("Sheet1").Range("A2:A" & d1 + 1).Value = CompArray
w3.Sheets("Sheet1").Range("B1").Resize(1, d2).Value = CompArray
w3.SaveAs Filename:=ThisWorkbook.path & "\OutputComposite", FileFormat:=6
w3.Close True
Else
End If
End Function
有什么想法吗?
这个有效:
Sheets(1).Range("A1").Value = 10
编辑:但是,以这种方式引用工作表时要小心,因为用户可以更改工作表的顺序
我有一个代码可以从当前工作簿(多个工作sheets)收集数据并以预定义的方式将该数据导出到新工作簿。
问题: 我用英文编写代码,所以我按名称引用了一些输出 sheets(例如 Sheet1)。但是,我希望此代码可以在 excel 中与其他语言首选项(例如 tabela1、tabelle1...)一起使用。如果我引用 "Sheet1",当用户处于不同的语言设置 excel 时,创建的新工作簿将具有不同名称的 sheet。
问题:我该如何解决这种情况?
已经试过: 代替原来的:
w2.Sheets("Sheet1").Range...
我尝试使用:
w2.Worksheets(1).Range...
但显然这不起作用(下标超出范围错误)
Obs1: 我也试过在新的工作簿中添加一个新的工作sheet,指定名称,并保持原来的代码,但是这种做法没那么优雅
Obs2: 代码的相关部分是将标识符、日期和内容数组粘贴到新的 sheet.
代码:
Function ArrayFiller(arr As Variant, arr0 As Variant, y As String, Optional ind As Boolean) As Variant
Dim lRow As Long, lColumn As Long
Dim w2 As Workbook
Dim w3 As Workbook
Dim d As Date, d1 As Long, d2 As Long
Dim CompArray() As Variant
Workbooks.Add
Set w2 = ActiveWorkbook
For lRow = LBound(arr, 1) To UBound(arr, 1)
For lColumn = LBound(arr, 2) + 1 To UBound(arr, 2)
If arr(lRow, lColumn) <> "" And arr(lRow, lColumn - 1) = "" Then
If arr0(lRow, lColumn) <> "" And arr0(lRow, lColumn) <> "--" Then
arr(lRow, lColumn - 1) = arr0(lRow, lColumn)
w2.Worksheets(1).Cells(lColumn - 1, lRow).Interior.Color = RGB(255, 0, 0)
ElseIf arr0(lRow, lColumn) = "" Or arr0(lRow, lColumn) = "--" Then
arr(lRow, lColumn - 1) = arr(lRow, lColumn)
w2.Worksheets(1).Cells(lColumn - 1, lRow).Interior.Color = RGB(255, 0, 0)
End If
End If
Next
Next
w2.Sheets("Sheet1").Range("A1").Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.WorksheetFunction.Transpose(arr)
Columns(2).EntireColumn.Delete
Rows(2).EntireRow.Delete
d = Application.WorksheetFunction.WorkDay(w2.Sheets("Sheet1").Range("A3"), -1)
w2.Sheets("Sheet1").Range("A2") = d
w2.SaveAs Filename:=ThisWorkbook.path & "\" & "Output" & y, FileFormat:=6
CompArray() = w2.Worksheets(1).UsedRange.Value
w2.Close True
d1 = UBound(CompArray, 1)
d2 = UBound(CompArray, 2)
If ind = True Then
Workbooks.Add
Set w3 = ActiveWorkbook
For lRow = LBound(CompArray, 1) + 1 To UBound(CompArray, 1)
For lColumn = LBound(CompArray, 2) + 1 To UBound(CompArray, 2)
If CompArray(lRow, lColumn) <> "" And CompArray(lRow, lColumn) <> "--" Then
w3.Worksheets(1).Cells(lRow, lColumn).Value = 1
Else
w3.Worksheets(1).Cells(lRow, lColumn).Value = 0
End If
Next
Next
Columns(1).EntireColumn.Insert
Rows(1).EntireRow.Insert
w3.Sheets("Sheet1").Range("A2:A" & d1 + 1).Value = CompArray
w3.Sheets("Sheet1").Range("B1").Resize(1, d2).Value = CompArray
w3.SaveAs Filename:=ThisWorkbook.path & "\OutputComposite", FileFormat:=6
w3.Close True
Else
End If
End Function
有什么想法吗?
这个有效:
Sheets(1).Range("A1").Value = 10
编辑:但是,以这种方式引用工作表时要小心,因为用户可以更改工作表的顺序