suresh ullanki
Board Regular
- Joined
- Apr 29, 2013
- Messages
- 67
Hi,
I tried my best to run the following code, but could not success. This code will be run from separate workbook. where all the macros are placed. it is throwing an error "Run time error '9', Subscript out of Range". I Guess somebody could help
Private Sub CommandButton1_Click()
Dim GetFile As Variant
MsgBox "Please select Source File and Target File"
GetFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open The Workbook", MultiSelect:=True)
On Error Resume Next
If GetFile <> False Then
On Error GoTo 0
For j = 1 To UBound(GetFile)
Workbooks.Open Filename:=GetFile(j)
Next j
End If
Dim lastrow As Long, wkb As Workbook, ws1 As Worksheet, ws2 As Worksheet, wkb1 As Workbook
Dim i As Long
Set wkb1 = Workbooks("Target File").Sheets("Format")
Set ws2 = wkb1.Sheets("Format")
Set wkb = ActiveWorkbook
Set ws1 = wkb.Sheets("Headcount Reg")
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To ws1.UsedRange.Columns.Count 'This can be changed to 70 if there are columns after BQ that are not copied.
Select Case i
Case Is <= 6
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i)
Case 8 To 14
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i - 1)
Case 15 To 16
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i + 3)
Case 17 To 38
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i + 5)
Case 39 To 45
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i + 7)
Case 46 To 47
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i + 23)
Case 48 To 58
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i + 5)
End Select
Next i
ws2.Activate
ws2.SaveAs Filename:="Schedule 7_Append", FileFormat:=xlCSV, CreateBackup:=False
End Sub
I tried my best to run the following code, but could not success. This code will be run from separate workbook. where all the macros are placed. it is throwing an error "Run time error '9', Subscript out of Range". I Guess somebody could help
Private Sub CommandButton1_Click()
Dim GetFile As Variant
MsgBox "Please select Source File and Target File"
GetFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open The Workbook", MultiSelect:=True)
On Error Resume Next
If GetFile <> False Then
On Error GoTo 0
For j = 1 To UBound(GetFile)
Workbooks.Open Filename:=GetFile(j)
Next j
End If
Dim lastrow As Long, wkb As Workbook, ws1 As Worksheet, ws2 As Worksheet, wkb1 As Workbook
Dim i As Long
Set wkb1 = Workbooks("Target File").Sheets("Format")
Set ws2 = wkb1.Sheets("Format")
Set wkb = ActiveWorkbook
Set ws1 = wkb.Sheets("Headcount Reg")
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To ws1.UsedRange.Columns.Count 'This can be changed to 70 if there are columns after BQ that are not copied.
Select Case i
Case Is <= 6
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i)
Case 8 To 14
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i - 1)
Case 15 To 16
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i + 3)
Case 17 To 38
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i + 5)
Case 39 To 45
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i + 7)
Case 46 To 47
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i + 23)
Case 48 To 58
Range(ws1.Cells(2, i), ws1.Cells(lastrow, i)).Copy Destination:=ws2.Cells(2, i + 5)
End Select
Next i
ws2.Activate
ws2.SaveAs Filename:="Schedule 7_Append", FileFormat:=xlCSV, CreateBackup:=False
End Sub