Lập VBA để tạo mới DS - từ sheet này qua sheet khác (1 người xem)

truong bach chien · 26/5/19

Mình đang cần lập DS được chép từ sheet 2 sang sheet1
(xem theo file đính kèm)
(sheet2 là DS nguồn, được up thường xuyên vào đây- sheet 1 là DS được làm mới mỗi khi bấm nút "LÀM MỚI")
Mong các ACE giúp dùm đoạn VBA này
Xin cám ơn nhiều

HieuCD · 26/5/19

truong bach chien đã viết:
Mình đang cần lập DS được chép từ sheet 2 sang sheet1
(xem theo file đính kèm)
(sheet2 là DS nguồn, được up thường xuyên vào đây- sheet 1 là DS được làm mới mỗi khi bấm nút "LÀM MỚI")
Mong các ACE giúp dùm đoạn VBA này
Xin cám ơn nhiều

Chạy code

Mã:

Private Sub butOk_Click()
  Dim sArr(), Res(), S, tmp As String
  Dim i As Long, n As Long, k As Long, sRow As Long
  Dim sR As Long, sC As Long, j As Long
 
  tmp = So_Nhom.Text
  If Len(tmp) = 0 Then MsgBox ("Phai nhap so thu tu nhom"): Exit Sub
  With Sheets("Sheet2")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Sheet2 Khong co du lieu"): Exit Sub
    sArr = .Range("A2:C" & i).Value
  End With
  sRow = UBound(sArr)
  sC = 2
  ReDim Res(1 To Len(tmp) - Len(Replace(tmp, ",", "")) + 1, 1 To sC)
  sR = UBound(Res)
  tmp = "," & tmp & ","
  For i = 1 To sRow
    If Len(sArr(i, 1)) > 0 Then
      If InStr(1, tmp, "," & sArr(i, 1) & ",") Then
        k = k + 1
        Res(k, 1) = sArr(i, 1)
        Res(k, 2) = sArr(i, 2) & " " & sArr(i, 3)
        j = 2
        For n = i + 1 To sRow
          If Len(sArr(n, 1)) > 0 Then Exit For
          If Len(sArr(n, 2)) > 0 Then
            j = j + 1
            If j > sC Then sC = j: ReDim Preserve Res(1 To sR, 1 To sC)
            Res(k, j) = sArr(n, 2) & " " & sArr(n, 3)
          End If
        Next n
      End If
    End If
  Next i
  Range("A2").CurrentRegion.Offset(1).ClearContents
  Range("A2").Resize(k, sC) = Res
End Sub

truong bach chien · 27/5/19

Cám ơn Anh HIEUCD nhiều
Chương trình code viết chạy được ngay.
Mong nhờ A giúp hộ luôn: phần số nhóm gõ rời thì tốt, nhưng phần SỐ NHÓM TỔNG thì không chạy được.
Cụ thể: nhập số nhóm rời: 1,4 thì code chạy được ngay
Nhập tổng nhóm (từ 1 đến 7): 1-7, thì code còn thiếu.
Xin cám ơn Anh HIEUCD nhiều

truong bach chien · 29/5/19

Mình đã copy đoạn code (anh HieuCD hướng dẫn) vào file, và chạy được với việc gõ từng nhóm (xem file đính kèm)
Nhưng chưa chạy được các nhóm gộp. Tức :
- khi mở file ra, kích vào nút "LÀM MỚI"
- Form "KhaiBao" xuất hiện
- Gõ vào khung các nhóm gộp, như: 1-4, 8, 10-13
(tức muốn chép DS các nhóm 1,2,3,4,8,10,11,12,13 từ sheet2 sang sheet1)
thì lệnh VBA chưa chạy được
Mong lần nữa các ACE (anh- chị - em) giúp dùm code cho nút "LÀM mỚI" này
Xin cám ơn

HieuCD · 29/5/19

truong bach chien đã viết:
Mình đã copy đoạn code (anh HieuCD hướng dẫn) vào file, và chạy được với việc gõ từng nhóm (xem file đính kèm)
Nhưng chưa chạy được các nhóm gộp. Tức :
- khi mở file ra, kích vào nút "LÀM MỚI"
- Form "KhaiBao" xuất hiện
- Gõ vào khung các nhóm gộp, như: 1-4, 8, 10-13
(tức muốn chép DS các nhóm 1,2,3,4,8,10,11,12,13 từ sheet2 sang sheet1)
thì lệnh VBA chưa chạy được
Mong lần nữa các ACE (anh- chị - em) giúp dùm code cho nút "LÀM mỚI" này
Xin cám ơn

Nhập dữ liệu vào form phải đúng chuẩn

Mã:

Private Sub butOk_Click()
  Dim Dic As Object, sArr(), Res(), S, S1, tmp As String
  Dim i As Long, n As Long, k As Long, sRow As Long
  Dim sR As Long, sC As Long, j As Long
 
  tmp = So_Nhom.Text
  If Len(tmp) = 0 Then MsgBox ("Phai nhap so thu tu nhom"): Exit Sub
  With Sheets("Sheet2")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Sheet2 Khong co du lieu"): Exit Sub
    sArr = .Range("A2:C" & i).Value
  End With
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(sArr)
  sC = 2
  ReDim Res(1 To sRow, 1 To sC)
 
  S = Split(tmp, ",")
  For i = 0 To UBound(S)
    If InStr(1, S(i), "_") Then
      S1 = Split(S(i), "_")
      If IsNumeric(S1(0)) And IsNumeric(S1(1)) Then
        For j = CLng(S1(0)) To CLng(S1(1))
          Dic.Item(j) = Empty
        Next j
      End If
    Else
      If IsNumeric(S(i)) Then Dic.Item(CLng(S(i))) = Empty
    End If
  Next i
 
  For i = 1 To sRow
    If Len(sArr(i, 1)) > 0 Then
      If Dic.exists(sArr(i, 1)) Then
        k = k + 1
        Res(k, 1) = sArr(i, 1)
        Res(k, 2) = sArr(i, 2) & " " & sArr(i, 3)
        j = 2
        For n = i + 1 To sRow
          If Len(sArr(n, 1)) > 0 Then Exit For
          If Len(sArr(n, 2)) > 0 Then
            j = j + 1
            If j > sC Then sC = j: ReDim Preserve Res(1 To sRow, 1 To sC)
            Res(k, j) = sArr(n, 2) & " " & sArr(n, 3)
          End If
        Next n
      End If
    End If
  Next i
  Range("A2").CurrentRegion.Offset(1).ClearContents
  Range("A2").Resize(k, sC) = Res
End Sub

truong bach chien · 30/5/19

HieuCD đã viết:
Nhập dữ liệu vào form phải đúng chuẩn

Mình đã nhập vào form Khaibao đúng CODE của anh HieuCD hướng dẫn
và chỉ thành công khi bám nút "LÀM MỚI" với cách nhập rời từng giá trị
(chẳng hạn nhập 1,4,7- thì chuyển được 3 nhóm 1,4,7 từ sheet 2 sang sheet1)
Nhưng muốn chuyển nhiều nhóm từ sheet 2 sang sheet1
(chẳng hạn muốn chuyển các nhóm 1,2,3,4,5,6,7,8,9,10 từ sheet2 sang sheet1, mà gõ từ số rất bất tiện
nên mình muốn nhập số gộp - ví dụ như gộp 1,2,3,4,5,6,7,8,9,10 thành 1-10. thì code lệnh :" Range("A2").Resize(k, sC) = Res" bị báo lỗi không thực hiện được.
(hay do mình không biết cách ghi nhóm gộp lại theo CODE của anh HieuCD)
Mong Anh HieuCD giúp lần nữa
xin càm ơn nhiều

Phuocam · 30/5/19

Bạn thay 2 dòng:

Mã:

If InStr(1, S(i), "_") Then
      S1 = Split(S(i), "_")

thành:

Mã:

If InStr(1, S(i), "-") Then
      S1 = Split(S(i), "-")

Tức là thay dấu nối dưới _ thành dấu trừ -

Bẫy lỗi thêm trong câu cuối cùng:

If k > 0 Then Range("A2").Resize(k, sC) = Res

truong bach chien · 30/5/19

phuocam đã viết:
Bạn thay 2 dòng:

Tuyệt vời
Cám ơn anh phuocam, anh HieuCD nhé
cám ơn mọi người quan tâm
Thanks

HieuCD · 30/5/19

truong bach chien đã viết:
Mình đã nhập vào form Khaibao đúng CODE của anh HieuCD hướng dẫn
và chỉ thành công khi bám nút "LÀM MỚI" với cách nhập rời từng giá trị
(chẳng hạn nhập 1,4,7- thì chuyển được 3 nhóm 1,4,7 từ sheet 2 sang sheet1)
Nhưng muốn chuyển nhiều nhóm từ sheet 2 sang sheet1
(chẳng hạn muốn chuyển các nhóm 1,2,3,4,5,6,7,8,9,10 từ sheet2 sang sheet1, mà gõ từ số rất bất tiện
nên mình muốn nhập số gộp - ví dụ như gộp 1,2,3,4,5,6,7,8,9,10 thành 1-10. thì code lệnh :" Range("A2").Resize(k, sC) = Res" bị báo lỗi không thực hiện được.
(hay do mình không biết cách ghi nhóm gộp lại theo CODE của anh HieuCD)
Mong Anh HieuCD giúp lần nữa
xin càm ơn nhiều

Thêm dòng lệnh

Mã:

Private Sub butOk_Click()
  Dim Dic As Object, sArr(), Res(), S, S1, tmp As String
  Dim i As Long, n As Long, k As Long, sRow As Long
  Dim sR As Long, sC As Long, j As Long
 
  tmp = So_Nhom.Text
  If Len(tmp) = 0 Then MsgBox ("Phai nhap so thu tu nhom"): Exit Sub
  With Sheets("Sheet2")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Sheet2 Khong co du lieu"): Exit Sub
    sArr = .Range("A2:C" & i).Value
  End With
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(sArr)
  sC = 2
  ReDim Res(1 To sRow, 1 To sC)
 
  S = Split(tmp, ",")
  For i = 0 To UBound(S)
    S(i) = Replace(S(i), "-", "_")
    If InStr(1, S(i), "_") Then
      S1 = Split(S(i), "_")
      If IsNumeric(S1(0)) And IsNumeric(S1(1)) Then
        For j = CLng(S1(0)) To CLng(S1(1))
          Dic.Item(j) = Empty
        Next j
      End If
    Else
      If IsNumeric(S(i)) Then Dic.Item(CLng(S(i))) = Empty
    End If
  Next i
 
  For i = 1 To sRow
    If Len(sArr(i, 1)) > 0 Then
      If Dic.exists(sArr(i, 1)) Then
        k = k + 1
        Res(k, 1) = sArr(i, 1)
        Res(k, 2) = sArr(i, 2) & " " & sArr(i, 3)
        j = 2
        For n = i + 1 To sRow
          If Len(sArr(n, 1)) > 0 Then Exit For
          If Len(sArr(n, 2)) > 0 Then
            j = j + 1
            If j > sC Then sC = j: ReDim Preserve Res(1 To sRow, 1 To sC)
            Res(k, j) = sArr(n, 2) & " " & sArr(n, 3)
          End If
        Next n
      End If
    End If
  Next i
  Range("A2").CurrentRegion.Offset(1).ClearContents
  If k Then Range("A2").Resize(k, sC) = Res
End Sub

truong bach chien · 31/5/19

HieuCD đã viết:

Thêm dòng lệnh

Mã:

Private Sub butOk_Click()
  Dim Dic As Object, sArr(), Res(), S, S1, tmp As String
  Dim i As Long, n As Long, k As Long, sRow As Long
  Dim sR As Long, sC As Long, j As Long

  tmp = So_Nhom.Text
  If Len(tmp) = 0 Then MsgBox ("Phai nhap so thu tu nhom"): Exit Sub
  With Sheets("Sheet2")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Sheet2 Khong co du lieu"): Exit Sub
    sArr = .Range("A2:C" & i).Value
  End With
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(sArr)
  sC = 2
  ReDim Res(1 To sRow, 1 To sC)

  S = Split(tmp, ",")
  For i = 0 To UBound(S)
    S(i) = Replace(S(i), "-", "_")
    If InStr(1, S(i), "_") Then
      S1 = Split(S(i), "_")
      If IsNumeric(S1(0)) And IsNumeric(S1(1)) Then
        For j = CLng(S1(0)) To CLng(S1(1))
          Dic.Item(j) = Empty
        Next j
      End If
    Else
      If IsNumeric(S(i)) Then Dic.Item(CLng(S(i))) = Empty
    End If
  Next i

  For i = 1 To sRow
    If Len(sArr(i, 1)) > 0 Then
      If Dic.exists(sArr(i, 1)) Then
        k = k + 1
        Res(k, 1) = sArr(i, 1)
        Res(k, 2) = sArr(i, 2) & " " & sArr(i, 3)
        j = 2
        For n = i + 1 To sRow
          If Len(sArr(n, 1)) > 0 Then Exit For
          If Len(sArr(n, 2)) > 0 Then
            j = j + 1
            If j > sC Then sC = j: ReDim Preserve Res(1 To sRow, 1 To sC)
            Res(k, j) = sArr(n, 2) & " " & sArr(n, 3)
          End If
        Next n
      End If
    End If
  Next i
  Range("A2").CurrentRegion.Offset(1).ClearContents
  If k Then Range("A2").Resize(k, sC) = Res
End Sub

Thanks anh HieuCD nhiều nhe
Chép code vào thì làm được ngay.
Thanks mọi người

Lập VBA để tạo mới DS - từ sheet này qua sheet khác (1 người xem)

Người dùng đang xem chủ đề này

truong bach chien

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

truong bach chien

Thành viên mới

truong bach chien

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

truong bach chien

Thành viên mới

File đính kèm

Phuocam

Thành viên mới

truong bach chien

Thành viên mới

HieuCD

Chuyên gia GPE

truong bach chien

Thành viên mới

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Sinh nhật lần 19 GPE