Excel Forum

Code: Select all

Sub ReRangeData()
Dim rs As Range, rt As Range
Dim lng As Long
Application.ScreenUpdating = False
With Worksheets("Sheet1")
    Set rs = .Range("A2", .Range("B2").End(xlDown))
End With
For lng = 1 To 7
    Set rt = Worksheets("Sheet1").Range("A2").End(xlDown).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
Next lng
Set rs = rs.Offset(0, 5).Resize(, 3)
For lng = 1 To 7
    Set rt = Worksheets("Sheet1").Range("C2").End(xlDown).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
    Set rs = rs.Offset(0, 3)
Next
Application.ScreenUpdating = True
End Sub

Code: Select all

Sub ReRangeData()
Dim rs As Range, rt As Range
Dim lng As Long, lngLr As Long
Application.ScreenUpdating = False
lngLr = Rows.Count
Worksheets("Sheet1").Range("A1:E1").Copy Worksheets("Sheet2").Range("A1")
With Worksheets("Sheet1")
    Set rs = .Range("A2", .Range("B2").End(xlDown))
End With
For lng = 1 To 8
    Set rt = Worksheets("Sheet2").Range("A" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
Next lng
Set rs = rs.Offset(0, 2).Resize(, 3)
For lng = 1 To 8
    Set rt = Worksheets("Sheet2").Range("C" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
    Set rs = rs.Offset(0, 3)
Next
Worksheets("Sheet2").Range("B1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub

Code: Select all

With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\swbpr\data\datafdu\PALM110815\FILEC.", Destination:=Range("$A$1"))
        .Name = "FILEC."
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 874
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(8, 1, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, _
        2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Columns("F:G").Select
    Selection.Delete Shift:=xlToLeft
    Columns("I:J").Select
    Selection.Delete Shift:=xlToLeft
    Columns("L:M").Select
    Selection.Delete Shift:=xlToLeft
    Columns("O:P").Select
    Selection.Delete Shift:=xlToLeft
    Columns("R:S").Select
    Selection.Delete Shift:=xlToLeft
    Columns("U:V").Select
    Selection.Delete Shift:=xlToLeft
    Columns("X:Y").Select
    Selection.Delete Shift:=xlToLeft
    Columns("AA:AB").Select
    Selection.Delete Shift:=xlToLeft

Code: Select all

Private Sub CommandButton1_Click()
Dim fileToOpen
Sheet3.Activate
ChDir "C:\swbpr\data\datafdu"
fileToOpen = Application.GetOpenFilename("FILEC ที่ได้จาก BPR->PALM,")
If fileToOpen <> False Then

Code: Select all

With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\swbpr\data\datafdu\PALM110815\FILEC.", Destination:=Range("$A$1"))'ให้ตรงนี้เปลี่ยนตามตำแหน่งFileC ที่ผู้ใช้เลือก

Code: Select all

Dim fileToOpen
Sheet3.Activate
ChDir "C:\swbpr\data\datafdu"
fileToOpen = Application.GetOpenFilename("FILEC ที่ได้จาก BPR->PALM,")
If fileToOpen = False Then
    MsgBox "Please select file."
    Exit Sub
End If
With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & fileToOpen, Destination:=Range("$A$1"))
' Other code
End With

Code: Select all

With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT; fileToOpen", Destination:=Range("$A$1"))
End With

Code: Select all

myPic = "D:\My Picture\" & TexBox1 & ".jpg"

Code: Select all

Private Sub CommandButton1_Click()
Dim fileToOpen
Sheet3.Activate
Sheet3.Range("A:AP").Value = ""
ChDir "C:\swbpr\data\datafdu"
fileToOpen = Application.GetOpenFilename("FILEC ·Õèä´é¨Ò¡ BPR->PALM,")
If fileToOpen <> False Then
Workbooks.OpenText Filename:="FILEC", _
        Origin:=874, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array( _
        Array(0, 1), Array(8, 1), Array(9, 1), Array(11, 1), Array(13, 1), Array(20, 1), Array(22, 1 _
        ), Array(24, 1), Array(26, 1), Array(28, 1), Array(35, 1), Array(37, 1), Array(39, 1), Array _
        (41, 1), Array(43, 1), Array(50, 1), Array(52, 1), Array(54, 1), Array(56, 1), Array(58, 1), _
        Array(65, 1), Array(67, 1), Array(69, 1), Array(71, 1), Array(73, 1), Array(80, 1), Array( _
        82, 1), Array(84, 1), Array(86, 1), Array(88, 1), Array(95, 1), Array(97, 1), Array(99, 1), _
        Array(101, 1), Array(103, 1), Array(110, 1), Array(112, 1), Array(114, 1), Array(116, 1), _
        Array(118, 1), Array(125, 1), Array(127, 1)), TrailingMinusNumbers:=True
        Sheets("FILEC").Range("A:AP").Select
          Selection.Copy
    Workbooks("z.xlsm").Worksheets("Sheet3").Activate
    Columns("A:A").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
  Workbooks("FILEC").Close , False
      End If
End Sub

Code: Select all

Private 
Sub	CommandButton8_Click()												
If TextBox1.Value	= Then												
Exit Sub															
End If															
[color=#FF0040]If ComboBox1.Value = เพื่อเป็นค่าลงทุนในการประกอบอาชีพอย่างอื่น Or ComboBox1.Value = เพื่อเป็นค่าใช้จ่ายในการประกอบอาชีพอย่างอื่น Or ComboBox1.Value = เพื่อเป็นค่าลงทุนในการพัฒนาคุณภาพชีวิต	Or ComboBox1.Value = เพื่อชำระหนี้สินภายนอก[/color] Then
MsgBox	ท่านทำสัญญานอกภาคการเกษตรครับ เลือก วิเคราะห์นอกภาค <= 300,000 ครับ, vbOKOnly,"DumP"							
Exit Sub															
End If															
If TextBox121.Value = ผลการวิเคราะห์ ลูกค้าสามารถชำระหนี้ได้	Then											
Sheet2.PrintOut																
Else																
MsgBox "โปรดแก้ไข รายรับรายจ่าย ครับ",	vbOKOnly,"DumP"												
Exit Sub															
End If															
End Sub

Code: Select all

'Other code
Select Case ComboBox1.Value
    Case "เพื่อเป็นค่าลงทุนในการประกอบอาชีพอย่างอื่น", " เพื่อเป็นค่าใช้จ่ายในการประกอบอาชีพอย่างอื่น", _
        "เพื่อเป็นค่าลงทุนในการพัฒนาคุณภาพชีวิต", "เพื่อชำระหนี้สินภายนอก"
        MsgBox "ท่านทำสัญญานอกภาคการเกษตรครับ เลือก วิเคราะห์นอกภาค <= 300,000 ครับ", vbOKOnly, "DumP"
        Exit Sub
    Case "ผลการวิเคราะห์ ลูกค้าสามารถชำระหนี้ได้"
        Sheet2.PrintOut
End Select
'Other code

Code: Select all

Case "ผลการวิเคราะห์ ลูกค้าสามารถชำระหนี้ได้"

Code: Select all

If TextBox121.Value = ผลการวิเคราะห์ ลูกค้าสามารถชำระหนี้ได้   Then                                 
Sheet2.PrintOut                                                
Else

Code: Select all

Private Sub UserForm_Click()

End Sub

Code: Select all

Worksheets("Sheet2").Range("B1").EntireColumn.Delete

Code: Select all

Private Sub CommandButton28_Click()
Dim fileToOpen
Dim rs As Range, rt As Range, ri As Range
Dim lng As Long, lngLr As Long
Sheet10.Range("A:D").Value = ""
Application.ScreenUpdating = False
Sheet22.Activate
Sheet22.Range("A1:AP1").Value = Sheet15.Range("A200:AP200").Value
ChDir "C:\swbpr\data\datafdu"
fileToOpen = Application.GetOpenFilename("FILEC ·Õèä´é¨Ò¡ BPR->PALM,")
If fileToOpen = False Then
    MsgBox "Please select file."
    Exit Sub
End If
With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & fileToOpen, Destination:=Range("$A$2"))
.Name = "FILEC."
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 874
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(8, 1, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, _
        2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=True
    End With
    Columns("F:G").Select
    Selection.Delete Shift:=xlToLeft
    Columns("I:J").Select
    Selection.Delete Shift:=xlToLeft
    Columns("L:M").Select
    Selection.Delete Shift:=xlToLeft
    Columns("O:P").Select
    Selection.Delete Shift:=xlToLeft
    Columns("R:S").Select
    Selection.Delete Shift:=xlToLeft
    Columns("U:V").Select
    Selection.Delete Shift:=xlToLeft
    Columns("X:Y").Select
    Selection.Delete Shift:=xlToLeft
    Columns("AA:AB").Select
    Selection.Delete Shift:=xlToLeft

ActiveSheet.QueryTables(1).Delete
Application.ScreenUpdating = False
lngLr = Rows.Count
Worksheets("DataC").Range("A1:E1").Copy Worksheets("FileC").Range("A1")
With Worksheets("DataC")
    Set rs = .Range("A2", .Range("B2").End(xlDown))
End With
For lng = 1 To 8
    Set rt = Worksheets("FileC").Range("A" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
Next lng
Set rs = rs.Offset(0, 2).Resize(, 3)
For lng = 1 To 8
    Set rt = Worksheets("FileC").Range("C" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
    Set rs = rs.Offset(0, 3)
Next
Worksheets("FileC").Range("B1").EntireColumn.Delete'ทำให้Colummเลื่อน แก้เป็นApplication.CutCopyMode = False
Sheet22.Range("A:Z").ClearContents
Application.ScreenUpdating = True

   'With Workbooks("DumP.xlsm").Worksheets("FileC") 'สั่งกรองข้อมูลเพื่อลบข้อมูลที่เป็น 0
'Set ri = .Range(.Range("A2"), .Range("D65536") _
    '.End(xlUp)).SpecialCells(xlCellTypeVisible)
'End With
   'Sheet10.Activate
            'Sheet10.Range("A:D").AutoFilter Field:=2, Criteria1:="0"
           'Sheet10.Range("A:D").AutoFilter Field:=3, Criteria1:="0"
           'Sheet10.Range("A:D").AutoFilter Field:=4, Criteria1:="0"
           'ri.Select
       'ri.Value = ""
       'Sheet10.ShowAllData
       'Sheets("FileC").Activate
                'Sheet10.Columns("A:D").Select
    'ActiveWorkbook.Worksheets("FileC").Sort.SortFields.Clear
    'ActiveWorkbook.Worksheets("FileC").Sort.SortFields.Add key:=Range("A1"), _
        'SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    'With ActiveWorkbook.Worksheets("FileC").Sort
        '.SetRange Range("A2:D65633")
        '.Header = xlNo
      '  .MatchCase = False
    '    .Orientation = xlTopToBottom
    '    .SortMethod = xlPinYin
        '.Apply
    'End With
    
    'Sheet22.Activate
    'Sheet22.Range("A:Z").Delete
     'Workbooks("DumP.xlsm").Save
End Sub

Code: Select all

Private Sub CommandButton5_Click()
Dim r As Integer
If Sheet10.Range("F2").Value <> "" Then
Exit Sub
End If
With Workbooks("DumP.xlsm").Worksheets("FileC")
 Application.ScreenUpdating = False
Sheets("FileC").Activate
Label18.Caption = "กำลังรวบรวมข้อมูล FileC %"
Sheet10.Range("W1").Value = "เขต"
Sheet10.Range("F1").Value = "เลขทะเบียน"
Sheet10.Range("G1").Value = "ชื่อ-สกุล"
Sheet10.Range("H1").Value = "ที่อยู่"
Sheet10.Range("I1").Value = "รหัสโครงการ"
r = 2
Do Until Sheet10.Cells(r, 1).Value = ""
Sheet10.Cells(r, 6).Formula = "=VLOOKUP(" & Sheet10.Cells(r, 1).Address & ",FileB!A:T,3,0)"
Sheet10.Cells(r, 7).Formula = "=VLOOKUP(" & Sheet10.Cells(r, 6).Address & ",FileA!A:G,5,0)"
Sheet10.Cells(r, 8).Formula = "=VLOOKUP(" & Sheet10.Cells(r, 6).Address & ",FileA!A:G,7,0)"
Sheet10.Cells(r, 9).Formula = "=VLOOKUP(" & Sheet10.Cells(r, 1).Address & ",FileB!A:T,17,0)"
Sheet10.Cells(r, 23).Formula = "=VLOOKUP(" & Sheet10.Cells(r, 6).Address & ",FileA!A:G,3,0)"
TextBox7.Value = Sheet10.Range("P1").Value
DoEvents
r = r + 1
Loop

 Sheet10.Range("J:J").Value = Sheet10.Range("F:F").Value
Sheet10.Range("K:K") = Sheet10.Range("G:G").Value
Sheet10.Range("L:L") = Sheet10.Range("H:H").Value
Sheet10.Range("M:M") = Sheet10.Range("I:I").Value
Sheet10.Range("E:E") = Sheet10.Range("W:W").Value
Sheet10.Range("F:I").Value = Sheet10.Range("J:M").Value
Sheet10.Range("J:M").ClearContents
Sheet10.Range("W:W").ClearContents
Label18.Caption = "ข้อมูล FileC สมบูรณ์  " & Now()
       MsgBox "รวบรวมข้อมูล FileC สมบูรณ์" , vbOKOnly, "DumP"
 Sheet10.Range("S1").Value = Label18.Caption
   End With
   Application.ScreenUpdating = True
   Workbooks("DumP.xlsm").Save
End Sub

Code: Select all

Sub DelZero()
Dim rAll As Range
Dim r As Range
With Worksheets("Sheet2")
    Set rAll = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
End With
For Each r In rAll
    If r = 0 And r.Offset(0, 1) = 0 And r.Offset(0, 2) = 0 Then
        r = ""
    End If
Next r
    On Error Resume Next
    rAll.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Code: Select all

Private Sub CommandButton28_Click()
Dim fileToOpen
Dim rs As Range, rt As Range, ri As Range
Dim lng As Long, lngLr As Long

Sheet10.Range("A:X").ClearContents
Application.ScreenUpdating = False
Sheet22.Activate
Sheet22.Range("A1:AP1").Value = Sheet15.Range("A200:AP200").Value
ChDir "C:\swbpr\data\datafdu"
fileToOpen = Application.GetOpenFilename("FILEC ·Õèä´é¨Ò¡ BPR->PALM,")
If fileToOpen = False Then
    MsgBox "Please select file."
    Exit Sub
End If
With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & fileToOpen, Destination:=Range("$A$2"))
.Name = "FILEC."
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 874
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(8, 1, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, _
        2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2, 2, 2, 2, 7, 2)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=True
    End With
    Columns("F:G").Select
    Selection.Delete Shift:=xlToLeft
    Columns("I:J").Select
    Selection.Delete Shift:=xlToLeft
    Columns("L:M").Select
    Selection.Delete Shift:=xlToLeft
    Columns("O:P").Select
    Selection.Delete Shift:=xlToLeft
    Columns("R:S").Select
    Selection.Delete Shift:=xlToLeft
    Columns("U:V").Select
    Selection.Delete Shift:=xlToLeft
    Columns("X:Y").Select
    Selection.Delete Shift:=xlToLeft
    Columns("AA:AB").Select
    Selection.Delete Shift:=xlToLeft

ActiveSheet.QueryTables(1).Delete
Application.ScreenUpdating = False
lngLr = Rows.Count
Worksheets("DataC").Range("A1:E1").Copy Worksheets("FileC").Range("A1")
With Worksheets("DataC")
    Set rs = .Range("A2", .Range("B2").End(xlDown))
End With
For lng = 1 To 8
    Set rt = Worksheets("FileC").Range("A" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
Next lng
Set rs = rs.Offset(0, 2).Resize(, 3)
For lng = 1 To 8
    Set rt = Worksheets("FileC").Range("C" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
    Set rs = rs.Offset(0, 3)
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheet22.Range("A:Z").ClearContents
Sheet10.Activate
Sheet10.Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
   With Workbooks("DumP.xlsm").Worksheets("FileC")
Set ri = .Range(.Range("A2"), .Range("D65536") _
    .End(xlUp)).SpecialCells(xlCellTypeVisible)
    Sheet10.Range("A:D").AutoFilter
             Sheet10.Range("A:D").AutoFilter Field:=4, Criteria1:="0"
         ri.Select
     ri.Value = ""
    Sheet10.ShowAllData
 End With
   
            Sheet10.Columns("A:D").Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        Sheet10.Range("N1").Formula = "=COUNTA(A:A)"
        Sheet10.Range("O1").Formula = "=COUNTA(F:F)"
        Sheet10.Range("P1").Formula = "=O1*100/N1"
    
        MsgBox "นำเข้าข้อมูล FileC สมบูรณ์", vbOKOnly, "DumP"
     
End Sub

Code: Select all

Worksheets("Sheet2").Range("B1").EntireColumn.Delete
ทำงานเป็นคำสั่งสุดท้าย 

Code: Select all

 Sheet10.Range("N1").Formula = "=COUNTA(A:A)"
        Sheet10.Range("O1").Formula = "=COUNTA(F:F)"
        Sheet10.Range("P1").Formula = "=O1*100/N1"

Code: Select all

Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheet22.Range("A:Z").ClearContents
Sheet10.Activate
Sheet10.Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft