单元格区域整理成一列（赋值给数组问题）在线等。谢谢

hbhm

要把rg2（红色单元格区域）的61个时间、以及该时间对应的员工编号、 员工姓名、 签卡日期 整理到sheets(1)的各列，
形成一个缺卡记录。
这个单元格区域处理不了，请各位大侠帮助。谢谢！！！！

在线等。谢谢 谢谢谢谢谢谢谢谢谢谢


Sub qianka()
Sheets.Add.Move Before:=ActiveSheet

Sheets(2).Select
Dim rg, rg2 As Range
Dim cishu, i As Integer

Set rg2 = ActiveSheet.Range(Cells(1, 8), Cells(Range("A1").CurrentRegion.Rows.Count, 11)).SpecialCells(xlCellTypeBlanks)
cishu = rg2.Cells.Count
    With rg2.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With

For Each rg In rg2
  If rg.Column = 8 Then rg.Value = "08:30:00"
  
  If rg.Column = 9 Then rg.Value = "12:00:00"
     
  If rg.Column = 10 Then rg.Value = "13:30:00"
   
  If rg.Column = 11 Then rg.Value = "18:00:00"
Next



'     Dim cel, rg_1 As Range
'     Dim arr() As Variant
'     Dim n As Integer
'
'
'    arr() = rg2.Value
'
'     For n = 0 To cishu
'         ReDim Preserve arr(n)
'         arr(n) = rg2  '从大到小写入数组
'    Next
'    Next
'
'     k = 0
'     For Each cel In Range(Cells(2, 4), Cells(cishu + 1, 4))
'         cel = arr(k)  '数组赋值到单元格
'        k = k + 1
'     Next cel
'
'
'
'rg2.Select
'
'Set rg2 = Selection
'
'Dim arr
'
'Set arr = rg2
'
'
'ActiveSheet.Range(Cells(2, 4), Cells(cishu + 1, 4)).Value = arr.Value
'
'
For i = 1 To cishu
Sheets(1).Cells(i + 1, 1) = Cells(rg2.Cells(i).Row, 1).Value
Sheets(1).Cells(i + 1, 2) = Cells(rg2.Cells(i).Row, 2).Value
Sheets(1).Cells(i + 1, 3) = Cells(rg2.Cells(i).Row, 4).Value
Sheets(1).Cells(i + 1, 4) = rg2.Value
Sheets(1).Cells(i + 1, 5).Value = "正常签卡"
Next i



Sheets(1).[A1:F1] = Array("员工编号", "员工姓名", "签卡日期", "时间", "签卡类型", "事由")
   With Sheets(1).Range("A1:F1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
       .Interior.Pattern = xlSolid
       .Interior.PatternColorIndex = xlAutomatic
       .Interior.ThemeColor = xlThemeColorLight2
       .Interior.TintAndShade = 0.799981688894314
       .Interior.PatternTintAndShade = 0
    End With


End Sub

hbhm

解决了单元格区域时间整理问题。但时间对应的其他列问题没有解决。
大神在哪儿？谢谢谢谢



Sub qianka()
Sheets.Add.Move Before:=ActiveSheet

Sheets(2).Select
Dim rg, rg2 As Range
Dim cishu, i As Integer

Set rg2 = ActiveSheet.Range(Cells(1, 8), Cells(Range("A1").CurrentRegion.Rows.Count, 11)).SpecialCells(xlCellTypeBlanks)
cishu = rg2.Cells.Count
    With rg2.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With

For Each rg In rg2
  If rg.Column = 8 Then rg.Value = "08:30:00"
  
  If rg.Column = 9 Then rg.Value = "12:00:00"
     
  If rg.Column = 10 Then rg.Value = "13:30:00"
   
  If rg.Column = 11 Then rg.Value = "18:00:00"
Next

    Dim DataRange, cel As Range
    Dim brr(), num(), nam(), dat(), leix()
    Dim n As Long
   

   
    Dim num1, nam1, dat1, leix1 As Range
   
'   Set num1 = Cells(cel.Row, 1)
'   Set nam1 = Cells(cel.Row, 2)
'   Set dat1 = Cells(cel.Row, 4)
  ' Set leix1 = "正常签卡"
   
   
    For Each cel In rg2
        n = n + 1
        ReDim Preserve brr(1 To n)
        brr(n) = cel.Value
        
        
'        num(n) = num1.Value
'        nam(n) = nam1.Value
'        dat(n) = dat1.Value
'     '   leix(n) = "正常签卡"
     
    Next
'     Sheets(1).[a2].Resize(UBound(brr)) = Application.Transpose(num)
'     Sheets(1).[b2].Resize(UBound(brr)) = Application.Transpose(nam)
'     Sheets(1).[c2].Resize(UBound(brr)) = Application.Transpose(dat)
    Sheets(1).[d2].Resize(UBound(brr)) = Application.Transpose(brr)
'
'     Sheets(1).[e2].Resize(UBound(brr)) = Application.Transpose(leix)


Sheets(1).[A1:F1] = Array("员工编号", "员工姓名", "签卡日期", "时间", "签卡类型", "事由")
   With Sheets(1).Range("A1:F1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
       .Interior.Pattern = xlSolid
       .Interior.PatternColorIndex = xlAutomatic
       .Interior.ThemeColor = xlThemeColorLight2
       .Interior.TintAndShade = 0.799981688894314
       .Interior.PatternTintAndShade = 0
    End With
Sheets(1).Columns("D:D").NumberFormatLocal = "[$-F400]h:mm:ss AM/PM"

End Sub

hbhm

如下黑体 代码  解决了单元格区域时间的问题，但时间对应的其他列如何解决？

求大神。谢谢 谢谢  谢谢




Sub qianka()
Sheets.Add.Move Before:=ActiveSheet

Sheets(2).Select
Dim rg, rg2 As Range
Dim cishu, i As Integer

Set rg2 = ActiveSheet.Range(Cells(1, 8), Cells(Range("A1").CurrentRegion.Rows.Count, 11)).SpecialCells(xlCellTypeBlanks)
cishu = rg2.Cells.Count
    With rg2.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With

For Each rg In rg2
  If rg.Column = 8 Then rg.Value = "08:30:00"
  
  If rg.Column = 9 Then rg.Value = "12:00:00"
     
  If rg.Column = 10 Then rg.Value = "13:30:00"
   
  If rg.Column = 11 Then rg.Value = "18:00:00"
Next

    Dim DataRange, cel As Range
    Dim brr(), num(), nam(), dat(), leix()
    Dim n As Long
   
'    Set DataRange = rg2
   
    Dim num1, nam1, dat1, leix1 As Range
   
'   Set num1 = Cells(cel.Row, 1)
'   Set nam1 = Cells(cel.Row, 2)
'   Set dat1 = Cells(cel.Row, 4)
  ' Set leix1 = "正常签卡"
   
   
    For Each cel In rg2
        n = n + 1
        ReDim Preserve brr(1 To n)
        brr(n) = cel.Value
        
        
'        num(n) = num1.Value
'        nam(n) = nam1.Value
'        dat(n) = dat1.Value
'     '   leix(n) = "正常签卡"
     
    Next
'     Sheets(1).[a2].Resize(UBound(brr)) = Application.Transpose(num)
'     Sheets(1).[b2].Resize(UBound(brr)) = Application.Transpose(nam)
'     Sheets(1).[c2].Resize(UBound(brr)) = Application.Transpose(dat)
     Sheets(1).[d2].Resize(UBound(brr)) = Application.Transpose(brr)
'
'     Sheets(1).[e2].Resize(UBound(brr)) = Application.Transpose(leix)


Sheets(1).[A1:F1] = Array("员工编号", "员工姓名", "签卡日期", "时间", "签卡类型", "事由")
   With Sheets(1).Range("A1:F1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
       .Interior.Pattern = xlSolid
       .Interior.PatternColorIndex = xlAutomatic
       .Interior.ThemeColor = xlThemeColorLight2
       .Interior.TintAndShade = 0.799981688894314
       .Interior.PatternTintAndShade = 0
    End With
Sheets(1).Columns("D:D").NumberFormatLocal = "[$-F400]h:mm:ss AM/PM"

End Sub

hbhm

这个帖子有用

如何将任意选定区域的单元格数据赋值于一个动态数组
http://club.excelhome.net/thread-880871-1-1.html
(出处: ExcelHome技术论坛)

hbhm

怎么取这个数组对应的单元格区域各单元格的行号列号？

hbhm

如何把区域rg2每个单元格对应的工号、姓名、日期分别生成新的数组是关键。有了这个数组后可以赋值给sheets(1)的相应列。求大神帮忙。谢谢谢谢

hbhm

自己完美解决！！！谢谢





Sub qianka()
Sheets.Add.Move Before:=ActiveSheet
Sheets(2).Select
Dim rg, rg2 As Range
Dim cishu, i As Integer
Dim n As Long
Dim brr(), num(), nam(), dat()
Set rg2 = ActiveSheet.Range(Cells(1, 8), Cells(Range("A1").CurrentRegion.Rows.Count, 11)).SpecialCells(xlCellTypeBlanks)
cishu = rg2.Cells.Count
    With rg2.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With

For Each rg In rg2
  If rg.Column = 8 Then rg.Value = "08:30:00"
  If rg.Column = 9 Then rg.Value = "12:00:00"
  If rg.Column = 10 Then rg.Value = "13:30:00"
  If rg.Column = 11 Then rg.Value = "18:00:00"
  
  
   n = n + 1
  
        
        ReDim Preserve num(1 To n)
           num(n) = Cells(rg.Row, 1).Value
   
        ReDim Preserve nam(1 To n)
          nam(n) = Cells(rg.Row, 2).Value
        
        ReDim Preserve dat(1 To n)
          dat(n) = Cells(rg.Row, 4).Value
        
        ReDim Preserve brr(1 To n)
          brr(n) = rg.Value
         
Next

Sheets(1).[a2].Resize(UBound(brr)) = Application.Transpose(num)
Sheets(1).[b2].Resize(UBound(brr)) = Application.Transpose(nam)
Sheets(1).[c2].Resize(UBound(brr)) = Application.Transpose(dat)
Sheets(1).[d2].Resize(UBound(brr)) = Application.Transpose(brr)
Sheets(1).[e2].Resize(UBound(brr)) = "正常签卡"
   
Sheets(1).[A1:F1] = Array("员工编号", "员工姓名", "签卡日期", "时间", "签卡类型", "事由")
   With Sheets(1).Range("A1:F1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
       .Interior.Pattern = xlSolid
       .Interior.PatternColorIndex = xlAutomatic
       .Interior.ThemeColor = xlThemeColorLight2
       .Interior.TintAndShade = 0.799981688894314
       .Interior.PatternTintAndShade = 0
    End With
Sheets(1).Columns("D:D").NumberFormatLocal = "[$-F400]h:mm:ss AM/PM"
Sheets(1).Columns("C:C").NumberFormatLocal = "yyyy-m-d"

End Sub